chell 0.4.0.2 → 0.5
raw patch · 6 files changed
+1201/−939 lines, 6 filesdep ~ansi-terminaldep ~patiencenew-uploaderPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: ansi-terminal, patience
API changes (from Hackage documentation)
Files
- Test/Chell.hs +398/−282
- Test/Chell/Main.hs +429/−349
- Test/Chell/Output.hs +147/−123
- Test/Chell/Types.hs +201/−171
- changelog.md +9/−0
- chell.cabal +17/−14
Test/Chell.hs view
@@ -37,93 +37,92 @@ -- >$ ./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++ -- * 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+ 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)@@ -136,15 +135,17 @@ import qualified Language.Haskell.TH as TH +import qualified Patience+ 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@@ -155,45 +156,69 @@ 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) }+newtype Assertions a =+ Assertions+ { unAssertions :: TestState -> IO (Maybe a, TestState) } -instance Functor Assertions where- fmap = liftM+instance Functor Assertions+ where+ fmap = liftM -instance Control.Applicative.Applicative Assertions where- pure = return- (<*>) = ap+instance Control.Applicative.Applicative Assertions+ where+ pure = return+ (<*>) = ap -instance Monad Assertions where- return x = Assertions (\s -> return (Just x, s))- m >>= f = Assertions (\s -> do- (maybe_a, s') <- unAssertions m s- case maybe_a of- Nothing -> return (Nothing, s')- Just a -> unAssertions (f a) s')+instance Monad Assertions+ where+ return x =+ Assertions (\s -> return (Just x, s)) -instance MonadIO Assertions where- liftIO io = Assertions (\s -> do- x <- io- return (Just x, s))+ m >>= f =+ Assertions+ (\s ->+ do+ (maybe_a, s') <- unAssertions m s+ case maybe_a of+ Nothing -> return (Nothing, s')+ Just a -> unAssertions (f a) s'+ ) +instance MonadIO Assertions+ where+ liftIO io =+ Assertions+ (\s ->+ do+ x <- io+ return (Just x, s)+ )+ -- | Convert a sequence of pass/fail assertions into a runnable test. -- -- @@@ -203,45 +228,58 @@ -- $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. --@@ -252,15 +290,18 @@ -- $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@@ -273,32 +314,41 @@ -- $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.@@ -310,17 +360,22 @@ -- $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.@@ -332,34 +387,43 @@ -- $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.@@ -374,10 +438,12 @@ -- $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'.@@ -392,10 +458,12 @@ -- $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@@ -403,19 +471,26 @@ -- | 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 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,67 +498,94 @@ -- | 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)@@ -493,47 +595,57 @@ -> 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' 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+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@@ -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,6 +1,6 @@ module Test.Chell.Main- ( defaultMain- ) where+ ( defaultMain+ ) where import Control.Applicative import Control.Monad (forM, forM_, when)@@ -19,374 +19,454 @@ import Test.Chell.Output import Test.Chell.Types -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\"}.")- 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')."- })+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. 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")+ 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,16 +1,16 @@ {-# 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) #ifdef MIN_VERSION_ansi_terminal@@ -19,141 +19,165 @@ 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- }+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,52 @@ 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) -- | 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@@ -56,32 +58,33 @@ -- | 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)+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)+ -- | Default test options. -- -- >$ ghci@@ -93,10 +96,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,70 +108,72 @@ -- 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)+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)+ -- | 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.- --- -- '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)+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)+ -- | An empty 'Location'; use the field accessors to populate this value. location :: Location location = Location "" "" Nothing@@ -177,27 +183,40 @@ -- 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- skipWhen_ p (Suite name children) = Suite name (map (skipWhen_ p) children)+instance SuiteOrTest Suite+ where+ skipIf_ skip s@(Suite name children) =+ if skip+ then Suite name (map (skipIf_ skip) children)+ else s -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 (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+ )+ -- | Conditionally skip tests. Use this to avoid commenting out tests -- which are currently broken, or do not work on the current platform. --@@ -276,44 +295,55 @@ -- >*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,9 @@+# Release history for `chell`++0.5 - 2019 Feb 16++ * Add support for `patience` 0.2+ * Drop support for `patience` 0.1+ * Add support for `ansi-terminal` 0.8++0.4.0.2 - 2017 Dec 12
chell.cabal view
@@ -1,16 +1,21 @@ name: chell-version: 0.4.0.2+version: 0.5++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>+maintainer: Chris Martin, Julie Moronuki build-type: Simple cabal-version: >= 1.6-category: Testing-bug-reports: mailto:jmillikin@gmail.com-homepage: https://john-millikin.com/software/chell/ -synopsis: A simple and intuitive library for automated testing.+homepage: https://github.com/typeclasses/chell+bug-reports: https://github.com/typeclasses/chell/issues++tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3+ description: Chell is a simple and intuitive library for automated testing. It natively supports assertion-based testing, and can use companion libraries@@ -49,14 +54,12 @@ PASS: 2 tests run, 2 tests passed @ -source-repository head- type: git- location: https://john-millikin.com/code/chell/+extra-source-files:+ changelog.md -source-repository this+source-repository head type: git- location: https://john-millikin.com/code/chell/- tag: chell_0.4.0.2+ location: https://github.com/typeclasses/chell.git flag color-output description: Enable colored output in test results@@ -69,7 +72,7 @@ base >= 4.1 && < 5.0 , bytestring >= 0.9 , options >= 1.0 && < 2.0- , patience >= 0.1 && < 0.2+ , patience >= 0.2 && < 0.3 , random >= 1.0 , template-haskell >= 2.3 , text@@ -77,7 +80,7 @@ if flag(color-output) build-depends:- ansi-terminal >= 0.5 && < 0.8+ ansi-terminal >= 0.5 && < 0.9 exposed-modules: Test.Chell