chell-0.5/Test/0000755000000000000000000000000013432130174011550 5ustar0000000000000000chell-0.5/Test/Chell/0000755000000000000000000000000013432130174012577 5ustar0000000000000000chell-0.5/Test/Chell.hs0000644000000000000000000004534213432130174013143 0ustar0000000000000000{-# 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. -- -- @ --{-\# LANGUAGE TemplateHaskell \#-} -- --import Test.Chell -- --suite_Math :: Suite --suite_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' [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 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 import qualified Language.Haskell.TH as TH import qualified Patience import Test.Chell.Main (defaultMain) import Test.Chell.Types -- | A single pass/fail assertion. Failed assertions include an explanatory -- message. data Assertion = AssertionPassed | AssertionFailed String deriving (Eq, Show) -- | See 'Assertion'. assertionPassed :: Assertion assertionPassed = AssertionPassed -- | See 'Assertion'. assertionFailed :: String -> Assertion assertionFailed = AssertionFailed -- | See 'assert' and 'expect'. class IsAssertion a where runAssertion :: a -> IO Assertion instance IsAssertion Assertion where runAssertion = return 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 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 instance Control.Applicative.Applicative Assertions where pure = return (<*>) = ap instance Monad Assertions where return x = Assertions (\s -> return (Just x, s)) m >>= f = Assertions (\s -> do (maybe_a, s') <- unAssertions m s case maybe_a of Nothing -> return (Nothing, s') Just a -> unAssertions (f a) s' ) instance 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. -- -- @ -- test_Equality :: Test -- test_Equality = assertions \"equality\" $ do -- $assert (1 == 1) -- $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) runAfterTest :: IORef [IO ()] -> 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)) -- | Cause a test to immediately fail, with a message. -- -- 'die' is a Template Haskell macro, to retain the source-file location from -- 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) |] dieAt :: TH.Loc -> String -> Assertions a 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 -- the filename and line number where @$trace@ was called. -- -- 'trace' is a Template Haskell macro, to retain the source-file location -- 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 |] traceAt :: TH.Loc -> String -> Assertions () 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))) -- | 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))) -- | Require an 'Either' value to be 'Left', and return its contents. If -- the value is 'Right', fail the test. -- -- 'requireLeft' is a Template Haskell macro, to retain the source-file -- 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 |] 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 "") -- | Require an 'Either' value to be 'Right', and return its contents. If -- the value is 'Left', fail the test. -- -- 'requireRight' is a Template Haskell macro, to retain the source-file -- 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 |] 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 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 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 -- | Check an assertion. If the assertion fails, the test will immediately -- fail. -- -- The assertion to check can be a boolean value, an 'Assertion', or an IO -- action returning one of the above. -- -- 'assert' is a Template Haskell macro, to retain the source-file location -- 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 |] -- | 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'. -- -- The assertion to check can be a boolean value, an 'Assertion', or an IO -- action returning one of the above. -- -- 'expect' is a Template Haskell macro, to retain the source-file location -- 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 |] assertBool :: Bool -> String -> Assertion 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) -- | 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) -- | 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) -- | Assert that some value is @Just@. just :: Maybe a -> Assertion just x = assertBool (isJust x) ("just: received Nothing") -- | Assert that some value is @Nothing@. nothing :: Show a => Maybe a -> Assertion 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 () -- | 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 () -- | 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" -- | 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" -- | 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) -- | 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) -- | 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) -- | 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) -- | Assert that two containers have the same items, in any order. 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 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 -- | Class for types which can be treated as text; see 'equalLines'. class IsText a where toLines :: a -> [a] unpack :: a -> String instance IsText String where toLines = lines unpack = id 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 -- | Uses @Data.ByteString.Char8@ 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 -- | 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 -- large inputs. equalLines :: (Ord a, IsText a) => a -> a -> Assertion equalLines x y = checkLinesDiff "equalLines" (toLines x) (toLines y) -- | Variant of 'equalLines' which allows a user-specified line-splitting -- predicate. equalLinesWith :: Ord a => (a -> [String]) -> a -> a -> Assertion 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 chell-0.5/Test/Chell/Main.hs0000644000000000000000000003553513432130174014032 0ustar0000000000000000module 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 import Test.Chell.Output import Test.Chell.Types data MainOptions = MainOptions { optVerbose :: Bool , optXmlReport :: String , optJsonReport :: String , optTextReport :: String , optSeed :: Maybe Int , optTimeout :: Maybe Int , optColor :: ColorMode } 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" instance Options MainOptions where defineOptions = pure MainOptions <*> defineOption optionType_bool (\o -> o { optionShortFlags = ['v'] , optionLongFlags = ["verbose"] , optionDefault = False , optionDescription = "Print more output." } ) <*> simpleOption "xml-report" "" "Write a parsable report to a given path, in XML." <*> simpleOption "json-report" "" "Write a parsable report to a given path, in JSON." <*> simpleOption "text-report" "" "Write a human-readable report to a given path." <*> simpleOption "seed" Nothing "The seed used for random numbers in (for example) quickcheck." <*> simpleOption "timeout" Nothing "The maximum duration of a test, in milliseconds." <*> defineOption optionType_ColorMode (\o -> o { optionLongFlags = ["color"] , optionDefault = ColorModeAuto , optionDescription = "Whether to enable color ('always', 'auto', or 'never')." } ) -- | A simple default main function, which runs a list of tests and logs -- statistics to stdout. defaultMain :: [Suite] -> IO () defaultMain suites = runCommand $ \opts args -> do -- validate/sanitize test options seed <- case optSeed opts of Just s -> return s Nothing -> randomIO timeout <- case optTimeout opts of Nothing -> return Nothing Just t -> if toInteger t * 1000 > toInteger (maxBound :: Int) then do hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large." return Nothing else return (Just t) let testOptions = defaultTestOptions { testOptionSeed = seed , testOptionTimeout = timeout } -- find which tests to run let allTests = concatMap suiteTests suites 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 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)] 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) 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" 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" 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") 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 () chell-0.5/Test/Chell/Output.hs0000644000000000000000000001021313432130174014430 0ustar0000000000000000{-# LANGUAGE CPP #-} module Test.Chell.Output ( Output , outputStart , outputResult , ColorMode(..) , plainOutput , colorOutput ) where import Control.Monad (forM_, unless, when) #ifdef MIN_VERSION_ansi_terminal import qualified System.Console.ANSI as AnsiTerminal #endif import Test.Chell.Types data Output = Output { outputStart :: Test -> IO () , outputResult :: Test -> TestResult -> IO () } plainOutput :: Bool -> Output plainOutput v = Output { outputStart = plainOutputStart v , outputResult = plainOutputResult v } plainOutputStart :: Bool -> Test -> IO () 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 _ _ _ = return () data ColorMode = 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 } colorOutputStart :: Bool -> Test -> IO () 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 _ _ _ = 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 "" 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" chell-0.5/Test/Chell/Types.hs0000644000000000000000000002254113432130174014243 0ustar0000000000000000module 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 import qualified Control.Exception import Control.Exception (SomeException, Handler(..), catches, throwIO) import System.Timeout (timeout) -- | A 'Test' is, essentially, an IO action that returns a 'TestResult'. Tests -- are aggregated into suites (see 'Suite'). data Test = Test String (TestOptions -> IO TestResult) 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 test = Test -- | Get the name a test was given when it was defined; see 'test'. testName :: Test -> String testName (Test name _) = name -- | 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) -- | Default test options. -- -- >$ ghci -- >Prelude> import Test.Chell -- > -- >Test.Chell> testOptionSeed defaultTestOptions -- >0 -- > -- >Test.Chell> testOptionTimeout defaultTestOptions -- >Nothing defaultTestOptions :: TestOptions defaultTestOptions = TestOptions { testOptionSeed = 0 , testOptionTimeout = Nothing } -- | The result of running a test. -- -- To support future extensions to the testing API, any users of this module -- 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) -- | 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) -- | An empty 'Failure'; use the field accessors to populate this value. failure :: Failure failure = Failure Nothing "" -- | Contains details about a location in the test source file. data Location = Location { -- | A path to a source file, or empty if not provided. -- -- 'locationFile' is a field accessor, and can be used to update -- a 'Location' value. locationFile :: String -- | A Haskell module name, or empty if not provided. -- -- 'locationModule' is a field accessor, and can be used to update -- a 'Location' value. , locationModule :: String -- | A line number, or Nothing if not provided. -- -- 'locationLine' is a field accessor, and can be used to update -- a 'Location' value. , locationLine :: Maybe Integer } deriving (Show, Eq) -- | An empty 'Location'; use the field accessors to populate this value. location :: Location location = Location "" "" Nothing -- | A suite is a named collection of tests. -- -- 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 class SuiteOrTest a where skipIf_ :: Bool -> a -> a skipWhen_ :: IO Bool -> a -> a instance SuiteOrTest Suite where skipIf_ skip s@(Suite name children) = if skip then Suite name (map (skipIf_ skip) children) else s skipWhen_ p (Suite name children) = Suite name (map (skipWhen_ p) children) instance SuiteOrTest Test where skipIf_ skip t@(Test name _) = if skip then Test name (\_ -> return TestSkipped) else t skipWhen_ p (Test name io) = Test name (\opts -> do skip <- p if skip then return TestSkipped else io opts ) -- | Conditionally skip tests. Use this to avoid commenting out tests -- which are currently broken, or do not work on the current platform. -- -- @ --tests :: Suite --tests = 'suite' \"tests\" -- [ test_Foo -- , 'skipIf' builtOnUnix test_WindowsSpecific -- , test_Bar -- ] -- @ -- skipIf :: SuiteOrTest a => Bool -> a -> a skipIf = skipIf_ -- | Conditionally skip tests, depending on the result of a runtime check. The -- predicate is checked before each test is started. -- -- @ --tests :: Suite --tests = 'suite' \"tests\" -- [ test_Foo -- , 'skipWhen' noNetwork test_PingGoogle -- , test_Bar -- ] -- @ skipWhen :: SuiteOrTest a => IO Bool -> a -> a skipWhen = skipWhen_ -- | Define a new 'Suite', with the given name and children. -- -- 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': -- -- @ --test_Addition :: Test --test_Subtraction :: Test --test_Show :: Test -- --suite_Math :: Suite --suite_Math = 'suite' \"math\" -- [ test_Addition -- , test_Subtraction -- ] -- --suite_Prelude :: Suite --suite_Prelude = 'suite' \"prelude\" -- ( -- [ test_Show -- ] -- ++ suiteTests suite_Math -- ) -- @ suite :: String -> [Test] -> Suite suite = Suite -- | Get a suite's name. Suite names may be any string, but are typically -- plain ASCII so users can easily type them on the command line. -- -- >$ ghci chell-example.hs -- >Ok, modules loaded: Main. -- > -- >*Main> suiteName tests_Math -- >"math" suiteName :: Suite -> String suiteName (Suite name _) = name -- | Get the full list of tests contained within this 'Suite'. Each test is -- given its full name within the test hierarchy, where names are separated -- by periods. -- -- >$ ghci chell-example.hs -- >Ok, modules loaded: Main. -- > -- >*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] -- | 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) 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)) chell-0.5/license.txt0000644000000000000000000000204113432110071013003 0ustar0000000000000000Copyright (c) 2011 John Millikin Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. chell-0.5/Setup.hs0000644000000000000000000000005613432110071012260 0ustar0000000000000000import Distribution.Simple main = defaultMain chell-0.5/chell.cabal0000644000000000000000000000404613432136640012714 0ustar0000000000000000name: chell version: 0.5 synopsis: A simple and intuitive library for automated testing. category: Testing license: MIT license-file: license.txt author: John Millikin maintainer: Chris Martin, Julie Moronuki build-type: Simple cabal-version: >= 1.6 homepage: https://github.com/typeclasses/chell bug-reports: https://github.com/typeclasses/chell/issues tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 description: Chell is a simple and intuitive library for automated testing. It natively supports assertion-based testing, and can use companion libraries 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 @ extra-source-files: changelog.md source-repository head type: git location: https://github.com/typeclasses/chell.git flag color-output 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.2 && < 0.3 , random >= 1.0 , template-haskell >= 2.3 , text , transformers >= 0.2 if flag(color-output) build-depends: ansi-terminal >= 0.5 && < 0.9 exposed-modules: Test.Chell other-modules: Test.Chell.Main Test.Chell.Output Test.Chell.Types chell-0.5/changelog.md0000644000000000000000000000027013432136640013105 0ustar0000000000000000# Release history for `chell` 0.5 - 2019 Feb 16 * Add support for `patience` 0.2 * Drop support for `patience` 0.1 * Add support for `ansi-terminal` 0.8 0.4.0.2 - 2017 Dec 12