diff --git a/Test/Chell.hs b/Test/Chell.hs --- a/Test/Chell.hs +++ b/Test/Chell.hs @@ -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 diff --git a/Test/Chell/Main.hs b/Test/Chell/Main.hs --- a/Test/Chell/Main.hs +++ b/Test/Chell/Main.hs @@ -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 "\n" - tell "\n" - mapM_ tellResult results - tell "" - - tellResult (t, result) = case result of - TestPassed notes -> do - tell "\t\n" - tellNotes notes - tell "\t\n" - TestSkipped -> do - tell "\t\n" - TestFailed notes fs -> do - tell "\t\n" - forM_ fs $ \f -> do - tell "\t\t\n" - tell "\t\t\t\n" - tell "\t\t\n" - Nothing -> tell "'/>\n" - tellNotes notes - tell "\t\n" - TestAborted notes msg -> do - tell "\t\n" - tell "\t\t\n" - tellNotes notes - tell "\t\n" - _ -> return () - - escapeXML = concatMap (\c -> case c of - '&' -> "&" - '<' -> "<" - '>' -> ">" - '"' -> """ - '\'' -> "'" - _ -> [c]) - - tellNotes notes = forM_ notes $ \(key, value) -> do - tell "\t\t\n" +xmlReport results = Writer.execWriter writer + where + tell = Writer.tell + writer = + do + tell "\n" + tell "\n" + mapM_ tellResult results + tell "" + + tellResult (t, result) = + case result of + TestPassed notes -> + do + tell "\t\n" + tellNotes notes + tell "\t\n" + TestSkipped -> + do + tell "\t\n" + TestFailed notes fs -> + do + tell "\t\n" + forM_ fs $ \f -> + do + tell "\t\t\n" + tell "\t\t\t\n" + tell "\t\t\n" + Nothing -> tell "'/>\n" + tellNotes notes + tell "\t\n" + TestAborted notes msg -> + do + tell "\t\n" + tell "\t\t\n" + tellNotes notes + tell "\t\n" + _ -> return () + + escapeXML = + concatMap + (\c -> + case c of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + _ -> [c] + ) + + tellNotes notes = forM_ notes $ \(key, value) -> + do + tell "\t\t\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 () diff --git a/Test/Chell/Output.hs b/Test/Chell/Output.hs --- a/Test/Chell/Output.hs +++ b/Test/Chell/Output.hs @@ -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" diff --git a/Test/Chell/Types.hs b/Test/Chell/Types.hs --- a/Test/Chell/Types.hs +++ b/Test/Chell/Types.hs @@ -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)) diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -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 diff --git a/chell.cabal b/chell.cabal --- a/chell.cabal +++ b/chell.cabal @@ -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 -maintainer: John Millikin +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