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