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