diff --git a/chell.cabal b/chell.cabal --- a/chell.cabal +++ b/chell.cabal @@ -1,5 +1,5 @@ name: chell -version: 0.2.5 +version: 0.3 license: MIT license-file: license.txt author: John Millikin @@ -19,26 +19,27 @@ An example test suite, which verifies the behavior of artithmetic operators. . @ - {-\# LANGUAGE OverloadedStrings \#-} {-\# LANGUAGE TemplateHaskell \#-} . import Test.Chell . - test_Math :: Suite - test_Math = suite \"math\" [test_Addition, test_Subtraction] + tests_Math :: Suite + tests_Math = suite \"math\" + test_Addition + test_Subtraction . - test_Addition :: Suite + test_Addition :: Test test_Addition = assertions \"addition\" $ do $expect (equal (2 + 1) 3) $expect (equal (1 + 2) 3) . - test_Subtraction :: Suite + test_Subtraction :: Test test_Subtraction = assertions \"subtraction\" $ do $expect (equal (2 - 1) 1) $expect (equal (1 - 2) (-1)) . main :: IO () - main = defaultMain [test_Math] + main = defaultMain [tests_Math] @ . @ @@ -49,12 +50,12 @@ source-repository head type: bazaar - location: https://john-millikin.com/branches/chell/0.2/ + location: https://john-millikin.com/branches/chell/0.3/ source-repository this type: bazaar - location: https://john-millikin.com/branches/chell/0.2/ - tag: chell_0.2.5 + location: https://john-millikin.com/branches/chell/0.3/ + tag: chell_0.3 flag color-output description: Enable colored output in test results @@ -72,7 +73,7 @@ , random >= 1.0 , system-filepath >= 0.4 && < 0.5 , template-haskell >= 2.3 - , text >= 0.7 + , text , transformers >= 0.2 if flag(color-output) diff --git a/lib/Test/Chell.hs b/lib/Test/Chell.hs --- a/lib/Test/Chell.hs +++ b/lib/Test/Chell.hs @@ -1,8 +1,40 @@ -{-# LANGUAGE OverloadedStrings #-} {-# 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 +-- +--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 module Test.Chell ( @@ -11,21 +43,25 @@ -- * Test suites , Suite - , suite , suiteName , suiteTests - , test + + -- ** Building test suites + , BuildSuite + , SuiteOrTest + , suite + + -- ** Skipping some tests , skipIf , skipWhen -- * Basic testing library - -- $doc-basic-testing - , Assertion (..) - , AssertionResult (..) - , IsAssertion , Assertions , assertions - , assertionsTest + , IsAssertion + , Assertion + , assertionPassed + , assertionFailed , assert , expect , die @@ -35,7 +71,7 @@ , requireLeft , requireRight - -- ** Assertions + -- ** Built-in assertions , equal , notEqual , equalWithin @@ -53,26 +89,37 @@ , equalItems , IsText , equalLines + , equalLinesWith - -- * Constructing tests - , Test (..) + -- * 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 - , TestResult (..) - , Failure (..) - , Location (..) - - -- * Deprecated - , fail ) where -import Prelude hiding (fail) - import qualified Control.Applicative import qualified Control.Exception import Control.Exception (Exception) @@ -88,67 +135,45 @@ import qualified Data.Text import Data.Text (Text) import qualified Data.Text.Lazy -import qualified Data.Text.IO import qualified Language.Haskell.TH as TH import Test.Chell.Main (defaultMain) import Test.Chell.Types --- | 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\" --- [ 'skipIf' builtOnUnix test_WindowsSpecific --- ] --- @ --- -skipIf :: Bool -> Suite -> Suite -skipIf skip = if skip then step else id where - step (SuiteTest (Test name _)) = SuiteTest - (Test name (\_ -> return TestSkipped)) - step (Suite name suites) = Suite name (map step suites) - --- | Conditionally skip tests, depending on the result of a runtime check. The --- predicate is checked before each test is started. --- --- @ ---tests = 'suite' \"tests\" --- [ 'skipWhen' noNetwork test_PingGoogle --- ] --- @ -skipWhen :: IO Bool -> Suite -> Suite -skipWhen p = step where - step (SuiteTest (Test name io)) = SuiteTest (Test name (\opts -> do - skip <- p - if skip then return TestSkipped else io opts)) - step (Suite name suites) = Suite name (map step suites) - --- $doc-basic-testing --- --- This library includes a few basic JUnit-style assertions, for use in --- simple test suites where depending on a separate test framework is too --- much trouble. +-- | A single pass/fail assertion. Failed assertions include an explanatory +-- message. +data Assertion + = AssertionPassed + | AssertionFailed String + deriving (Eq, Show) -newtype Assertion = Assertion (IO AssertionResult) +-- | See 'Assertion'. +assertionPassed :: Assertion +assertionPassed = AssertionPassed -data AssertionResult - = AssertionPassed - | AssertionFailed Text +-- | See 'Assertion'. +assertionFailed :: String -> Assertion +assertionFailed = AssertionFailed +-- | See 'assert' and 'expect'. class IsAssertion a where - toAssertion :: a -> Assertion + runAssertion :: a -> IO Assertion instance IsAssertion Assertion where - toAssertion = id + runAssertion = return instance IsAssertion Bool where - toAssertion x = Assertion (return (if x - then AssertionPassed - else AssertionFailed "$assert: boolean assertion failed")) + runAssertion x = return $ if x + then assertionPassed + else assertionFailed "boolean assertion failed" -type TestState = (IORef [(Text, Text)], IORef [IO ()], [Failure]) +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 @@ -174,25 +199,13 @@ -- | Convert a sequence of pass/fail assertions into a runnable test. -- -- @ --- test_Equality :: Suite +-- test_Equality :: Test -- test_Equality = assertions \"equality\" $ do -- $assert (1 == 1) -- $assert (equal 1 1) -- @ -assertions :: Text -> Assertions a -> Suite -assertions name io = test (assertionsTest name io) - --- | Convert a sequence of pass/fail assertions into a runnable test. --- --- This is easier to use than 'assertions' when the result is going to be --- modified (eg, by a wrapper) before being used in a test suite. --- --- Most users should use 'assertions' instead, to avoid the extra wrapping --- step. --- --- Since: 0.2.3 -assertionsTest :: Text -> Assertions a -> Test -assertionsTest name testm = Test name $ \opts -> do +assertions :: String -> Assertions a -> Test +assertions name testm = test name $ \opts -> do noteRef <- newIORef [] afterTestRef <- newIORef [] @@ -217,16 +230,20 @@ loop [] = return () loop (io:ios) = Control.Exception.finally (loop ios) io -addFailure :: Maybe TH.Loc -> Text -> Assertions () +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 = Data.Text.pack (TH.loc_filename th_loc) - , locationModule = Data.Text.pack (TH.loc_module th_loc) - , locationLine = toInteger (fst (TH.loc_start th_loc)) + return $ location + { locationFile = TH.loc_filename th_loc + , locationModule = TH.loc_module th_loc + , locationLine = Just (toInteger (fst (TH.loc_start th_loc))) } - return (Just (), (notes, afterTestRef, Failure loc msg : fs)) + let f = failure + { failureLocation = loc + , failureMessage = msg + } + return (Just (), (notes, afterTestRef, f : fs)) -- | Cause a test to immediately fail, with a message. -- @@ -236,42 +253,50 @@ -- @ -- $die :: 'String' -> 'Assertions' a -- @ --- --- Since: 0.2.4 die :: TH.Q TH.Exp die = do loc <- TH.location let qloc = liftLoc loc - [| \msg -> dieAt $qloc (Data.Text.pack ("die: " ++ msg)) |] + [| \msg -> dieAt $qloc ("die: " ++ msg) |] -dieAt :: TH.Loc -> Text -> Assertions a +dieAt :: TH.Loc -> String -> Assertions a dieAt loc msg = do addFailure (Just loc) msg Assertions (\s -> return (Nothing, s)) -{-# DEPRECATED fail "Test.Chell.fail is deprecated; use Test.Chell.die instead." #-} --- | Deprecated in 0.2.4: use 'die' instead. -fail :: TH.Q TH.Exp -- :: Text -> Assertions a -fail = do +-- | 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 - [| dieAt $qloc |] + [| traceAt $qloc |] --- | Print a message from within a test. This is just a helper for debugging, --- so you don't have to import @Debug.Trace@. -trace :: Text -> Assertions () -trace msg = liftIO (Data.Text.IO.putStrLn msg) +traceAt :: TH.Loc -> String -> Assertions () +traceAt loc msg = liftIO $ do + let file = TH.loc_filename loc + let line = fst (TH.loc_start loc) + putStr ("[" ++ file ++ ":" ++ show line ++ "] ") + putStrLn msg --- | Attach metadata to a test run. This will be included in reports. -note :: Text -> Text -> Assertions () +-- | 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 threw an exception. --- --- Since: 0.2.3 +-- will run even if the test failed or aborted. afterTest :: IO () -> Assertions () afterTest io = Assertions (\(notes, ref, fs) -> do modifyIORef ref (io :) @@ -286,8 +311,6 @@ -- @ -- $requireLeft :: 'Show' b => 'Either' a b -> 'Assertions' a -- @ --- --- Since: 0.2.4 requireLeft :: TH.Q TH.Exp requireLeft = do loc <- TH.location @@ -299,7 +322,7 @@ Left a -> return a Right b -> do let dummy = Right b `asTypeOf` Left () - dieAt loc (Data.Text.pack ("requireLeft: received " ++ showsPrec 11 dummy "")) + 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. @@ -310,8 +333,6 @@ -- @ -- $requireRight :: 'Show' a => 'Either' a b -> 'Assertions' b -- @ --- --- Since: 0.2.4 requireRight :: TH.Q TH.Exp requireRight = do loc <- TH.location @@ -322,7 +343,7 @@ requireRightAt loc val = case val of Left a -> do let dummy = Left a `asTypeOf` Right () - dieAt loc (Data.Text.pack ("requireRight: received " ++ showsPrec 11 dummy "")) + dieAt loc ("requireRight: received " ++ showsPrec 11 dummy "") Right b -> return b liftLoc :: TH.Loc -> TH.Q TH.Exp @@ -335,47 +356,52 @@ assertAt :: IsAssertion assertion => TH.Loc -> Bool -> assertion -> Assertions () assertAt loc fatal assertion = do - let Assertion io = toAssertion assertion - result <- liftIO io + result <- liftIO (runAssertion assertion) case result of AssertionPassed -> return () AssertionFailed err -> if fatal then dieAt loc err else addFailure (Just loc) err --- | Run an 'Assertion'. If the assertion fails, the test will immediately +-- | 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 -- :: IsAssertion assertion => assertion -> Assertions () +assert :: TH.Q TH.Exp assert = do loc <- TH.location let qloc = liftLoc loc [| assertAt $qloc True |] --- | Run an 'Assertion'. If the assertion fails, the test will continue to --- run until it finishes (or until an 'assert' fails). +-- | 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 -- :: IsAssertion assertion => assertion -> Assertions () +expect :: TH.Q TH.Exp expect = do loc <- TH.location let qloc = liftLoc loc [| assertAt $qloc False |] pure :: Bool -> String -> Assertion -pure True _ = Assertion (return AssertionPassed) -pure False err = Assertion (return (AssertionFailed (Data.Text.pack err))) +pure True _ = assertionPassed +pure False err = AssertionFailed err -- | Assert that two values are equal. equal :: (Show a, Eq a) => a -> a -> Assertion @@ -398,45 +424,45 @@ just x = pure (isJust x) ("just: received Nothing") -- | Assert that some value is @Nothing@. -nothing :: Maybe a -> Assertion -nothing x = pure (isNothing x) ("nothing: received Just") +nothing :: Show a => Maybe a -> Assertion +nothing x = pure (isNothing x) ("nothing: received " ++ showsPrec 11 x "") -- | Assert that some value is @Left@. -left :: Either a b -> Assertion -left x = pure (isLeft x) ("left: received Right") where - isLeft (Left _) = True - isLeft (Right _) = False +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 :: Either a b -> Assertion -right x = pure (isRight x) ("right: received Left") where - isRight (Left _) = False - isRight (Right _) = True +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 -> Assertion -throws p io = Assertion (do +throws :: Exception err => (err -> Bool) -> IO a -> IO Assertion +throws p io = do either_exc <- Control.Exception.try io - return (case either_exc of + return $ case either_exc of Left exc -> if p exc - then AssertionPassed - else AssertionFailed (Data.Text.pack ("throws: exception " ++ show exc ++ " did not match predicate")) - Right _ -> AssertionFailed (Data.Text.pack ("throws: no exception thrown")))) + 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 -> Assertion -throwsEq expected io = Assertion (do +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 + return $ case either_exc of Left exc -> if exc == expected - then AssertionPassed - else AssertionFailed (Data.Text.pack ("throwsEq: exception " ++ show exc ++ " is not equal to " ++ show expected)) - Right _ -> AssertionFailed (Data.Text.pack ("throwsEq: no exception thrown")))) + 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 @@ -484,7 +510,7 @@ errorMsg diff = label ++ ": items differ\n" ++ diff --- | Class for types which can be treated as text. +-- | Class for types which can be treated as text; see 'equalLines'. class IsText a where toLines :: a -> [a] unpack :: a -> String @@ -515,8 +541,16 @@ -- 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 = checkDiff (toLines x) (toLines y) where - checkDiff xs ys = case checkItems (Patience.diff xs ys) of +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) -> pure same diff checkItems diffItems = case foldl' checkItem (True, []) diffItems of @@ -527,4 +561,4 @@ Patience.New t -> (False, ("\t+ " ++ unpack t) : acc) Patience.Both t _-> (same, ("\t " ++ unpack t) : acc) - errorMsg diff = "equalLines: lines differ\n" ++ diff + errorMsg diff = label ++ ": lines differ\n" ++ diff diff --git a/lib/Test/Chell/Main.hs b/lib/Test/Chell/Main.hs --- a/lib/Test/Chell/Main.hs +++ b/lib/Test/Chell/Main.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Test.Chell.Main @@ -9,14 +8,10 @@ import Control.Monad.Trans.Class (lift) import qualified Control.Monad.Trans.State as State import qualified Control.Monad.Trans.Writer as Writer -import qualified Data.ByteString import Data.Char (ord) -import qualified Data.Text -import Data.Text (Text, pack) -import qualified Data.Text.Encoding -import qualified Data.Text.IO +import Data.List (isPrefixOf) import System.Exit (exitSuccess, exitFailure) -import qualified System.IO as IO +import System.IO (hPutStr, hPutStrLn, hIsTerminalDevice, stderr, stdout, withBinaryFile, IOMode(..)) import System.Random (randomIO) import Text.Printf (printf) @@ -35,11 +30,11 @@ , optionDescription = "Print more output" }) - pathOption "optXmlReport" "xml-report" "" + pathOption "optXmlReport" "xml-report" Path.empty "Write a parsable report to a given path, in XML." - pathOption "optJsonReport" "json-report" "" + pathOption "optJsonReport" "json-report" Path.empty "Write a parsable report to a given path, in JSON." - pathOption "optTextReport" "text-report" "" + pathOption "optTextReport" "text-report" Path.empty "Write a human-readable report to a given path." option "optSeed" (\o -> o @@ -65,10 +60,11 @@ ] , optionDefault = "auto" , optionDescription = "Whether to enable color ('always', 'auto', or 'never')." - })) + }) + ) -- | A simple default main function, which runs a list of tests and logs --- statistics to stderr. +-- statistics to stdout. defaultMain :: [Suite] -> IO () defaultMain suites = runCommand $ \opts args -> do -- validate/sanitize test options @@ -79,7 +75,7 @@ Nothing -> return Nothing Just t -> if toInteger t * 1000 > toInteger (maxBound :: Int) then do - IO.hPutStrLn IO.stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large." + hPutStrLn stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large." return Nothing else return (Just t) let testOptions = defaultTestOptions @@ -98,7 +94,7 @@ ColorModeNever -> return (plainOutput (optVerbose opts)) ColorModeAlways -> return (colorOutput (optVerbose opts)) ColorModeAuto -> do - isTerm <- IO.hIsTerminalDevice IO.stdout + isTerm <- hIsTerminalDevice stdout return $ if isTerm then colorOutput (optVerbose opts) else plainOutput (optVerbose opts) @@ -113,28 +109,25 @@ -- generate reports let reports = getReports opts forM_ reports $ \(path, fmt, toText) -> - IO.withBinaryFile path IO.WriteMode $ \h -> do - let text = toText results - let bytes = Data.Text.Encoding.encodeUtf8 text + withBinaryFile path WriteMode $ \h -> do when (optVerbose opts) $ do putStrLn ("Writing " ++ fmt ++ " report to " ++ show path) - Data.ByteString.hPut h bytes + hPutStr h (toText results) let stats = resultStatistics results let (_, _, failed, aborted) = stats - Data.Text.IO.putStrLn (formatResultStatistics stats) + putStrLn (formatResultStatistics stats) if failed == 0 && aborted == 0 then exitSuccess else exitFailure matchesFilter :: [String] -> Test -> Bool -matchesFilter strFilters = check where - filters = map Data.Text.pack strFilters +matchesFilter filters = check where check t = any (matchName (testName t)) filters - matchName name f = f == name || Data.Text.isPrefixOf (Data.Text.append f ".") name + matchName name f = f == name || isPrefixOf (f ++ ".") name -type Report = [(Test, TestResult)] -> Text +type Report = [(Test, TestResult)] -> String getReports :: MainOptions -> [(String, String, Report)] getReports opts = concat [xml, json, text] where @@ -148,7 +141,7 @@ p | Path.null p -> [] p -> [(Path.encodeString p, "text", textReport)] -jsonReport :: [(Test, TestResult)] -> Text +jsonReport :: [(Test, TestResult)] -> String jsonReport results = Writer.execWriter writer where tell = Writer.tell @@ -172,18 +165,21 @@ tell "{\"test\": \"" tell (escapeJSON (testName t)) tell "\", \"result\": \"failed\", \"failures\": [" - commas fs $ \(Failure loc msg) -> do + commas fs $ \f -> do tell "{\"message\": \"" - tell (escapeJSON msg) + tell (escapeJSON (failureMessage f)) tell "\"" - case loc of - Just loc' -> do + case failureLocation f of + Just loc -> do tell ", \"location\": {\"module\": \"" - tell (escapeJSON (locationModule loc')) + tell (escapeJSON (locationModule loc)) tell "\", \"file\": \"" - tell (escapeJSON (locationFile loc')) - tell "\", \"line\": " - tell (pack (show (locationLine loc'))) + tell (escapeJSON (locationFile loc)) + case locationLine loc of + Just line -> do + tell "\", \"line\": " + tell (show line) + Nothing -> tell "\"" tell "}" Nothing -> return () tell "}" @@ -198,12 +194,13 @@ tell "\"}" tellNotes notes tell "}" + _ -> return () - escapeJSON = Data.Text.concatMap (\c -> case c of + escapeJSON = concatMap (\c -> case c of '"' -> "\\\"" '\\' -> "\\\\" - _ | ord c <= 0x1F -> pack (printf "\\u%04X" (ord c)) - _ -> Data.Text.singleton c) + _ | ord c <= 0x1F -> printf "\\u%04X" (ord c) + _ -> [c]) tellNotes notes = do tell ", \"notes\": [" @@ -225,7 +222,7 @@ State.put True lift (block x) -xmlReport :: [(Test, TestResult)] -> Text +xmlReport :: [(Test, TestResult)] -> String xmlReport results = Writer.execWriter writer where tell = Writer.tell @@ -250,18 +247,21 @@ tell "\t\n" - forM_ fs $ \(Failure loc msg) -> do + forM_ fs $ \f -> do tell "\t\t do + tell (escapeXML (failureMessage f)) + case failureLocation f of + Just loc -> do tell "'>\n" tell "\t\t\t do + tell "' line='" + tell (show line) + Nothing -> return () tell "'/>\n" tell "\t\t\n" Nothing -> tell "'/>\n" @@ -276,14 +276,15 @@ tell "'/>\n" tellNotes notes tell "\t\n" + _ -> return () - escapeXML = Data.Text.concatMap (\c -> case c of + escapeXML = concatMap (\c -> case c of '&' -> "&" '<' -> "<" '>' -> ">" '"' -> """ '\'' -> "'" - _ -> Data.Text.singleton c) + _ -> [c]) tellNotes notes = forM_ notes $ \(key, value) -> do tell "\t\t\n" -textReport :: [(Test, TestResult)] -> Text +textReport :: [(Test, TestResult)] -> String textReport results = Writer.execWriter writer where tell = Writer.tell @@ -303,7 +304,7 @@ tellResult (t, result) = case result of TestPassed notes -> do - tell (Data.Text.replicate 70 "=") + tell (replicate 70 '=') tell "\n" tell "PASSED: " tell (testName t) @@ -311,41 +312,45 @@ tellNotes notes tell "\n\n" TestSkipped -> do - tell (Data.Text.replicate 70 "=") + tell (replicate 70 '=') tell "\n" tell "SKIPPED: " tell (testName t) tell "\n\n" TestFailed notes fs -> do - tell (Data.Text.replicate 70 "=") + tell (replicate 70 '=') tell "\n" tell "FAILED: " tell (testName t) tell "\n" tellNotes notes - tell (Data.Text.replicate 70 "-") + tell (replicate 70 '-') tell "\n" - forM_ fs $ \(Failure loc msg) -> do - case loc of - Just loc' -> do - tell (locationFile loc') - tell ":" - tell (pack (show (locationLine loc'))) + 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 msg + tell (failureMessage f) tell "\n\n" TestAborted notes msg -> do - tell (Data.Text.replicate 70 "=") + tell (replicate 70 '=') tell "\n" tell "ABORTED: " tell (testName t) tell "\n" tellNotes notes - tell (Data.Text.replicate 70 "-") + tell (replicate 70 '-') tell "\n" tell msg tell "\n\n" + _ -> return () tellNotes notes = forM_ notes $ \(key, value) -> do tell key @@ -353,7 +358,7 @@ tell value tell "\n" -formatResultStatistics :: (Integer, Integer, Integer, Integer) -> Text +formatResultStatistics :: (Integer, Integer, Integer, Integer) -> String formatResultStatistics stats = Writer.execWriter writer where writer = do let (passed, skipped, failed, aborted) = stats @@ -361,8 +366,8 @@ then Writer.tell "PASS: " else Writer.tell "FAIL: " let putNum comma n what = Writer.tell $ if n == 1 - then pack (comma ++ "1 test " ++ what) - else pack (comma ++ show n ++ " tests " ++ what) + then comma ++ "1 test " ++ what + else comma ++ show n ++ " tests " ++ what let total = sum [passed, skipped, failed, aborted] putNum "" total "run" @@ -378,3 +383,4 @@ 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/lib/Test/Chell/Output.hs b/lib/Test/Chell/Output.hs --- a/lib/Test/Chell/Output.hs +++ b/lib/Test/Chell/Output.hs @@ -1,14 +1,17 @@ {-# LANGUAGE CPP #-} module Test.Chell.Output - ( Output(..) + ( Output + , outputStart + , outputResult + + , ColorMode(..) + , plainOutput , colorOutput ) where import Control.Monad (forM_, unless, when) -import Data.Text (Text) -import qualified Data.Text.IO #ifdef MIN_VERSION_ansi_terminal import qualified System.Console.ANSI as AnsiTerminal @@ -30,30 +33,37 @@ plainOutputStart :: Bool -> Test -> IO () plainOutputStart v t = when v $ do putStr "[ RUN ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) plainOutputResult :: Bool -> Test -> TestResult -> IO () plainOutputResult v t (TestPassed _) = when v $ do putStr "[ PASS ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) putStrLn "" plainOutputResult v t TestSkipped = when v $ do putStr "[ SKIP ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) putStrLn "" plainOutputResult _ t (TestFailed notes fs) = do putStr "[ FAIL ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) printNotes notes printFailures fs plainOutputResult _ t (TestAborted notes msg) = do putStr "[ ABORT ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) printNotes notes putStr " " - Data.Text.IO.putStr msg + putStr msg putStrLn "\n" +plainOutputResult _ _ _ = return () +data ColorMode + = ColorModeAuto + | ColorModeAlways + | ColorModeNever + deriving (Enum) + colorOutput :: Bool -> Output #ifndef MIN_VERSION_ansi_terminal colorOutput = plainOutput @@ -66,7 +76,7 @@ colorOutputStart :: Bool -> Test -> IO () colorOutputStart v t = when v $ do putStr "[ RUN ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) colorOutputResult :: Bool -> Test -> TestResult -> IO () colorOutputResult v t (TestPassed _) = when v $ do @@ -79,7 +89,7 @@ [ AnsiTerminal.Reset ] putStr " ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) putStrLn "" colorOutputResult v t TestSkipped = when v $ do putStr "[ " @@ -91,7 +101,7 @@ [ AnsiTerminal.Reset ] putStr " ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) putStrLn "" colorOutputResult _ t (TestFailed notes fs) = do putStr "[ " @@ -103,7 +113,7 @@ [ AnsiTerminal.Reset ] putStr " ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) printNotes notes printFailures fs colorOutputResult _ t (TestAborted notes msg) = do @@ -116,31 +126,34 @@ [ AnsiTerminal.Reset ] putStr " ] " - Data.Text.IO.putStrLn (testName t) + putStrLn (testName t) printNotes notes putStr " " - Data.Text.IO.putStr msg + putStr msg putStrLn "\n" +colorOutputResult _ _ _ = return () #endif -printNotes :: [(Text, Text)] -> IO () +printNotes :: [(String, String)] -> IO () printNotes notes = unless (null notes) $ do forM_ notes $ \(key, value) -> do putStr " note: " - Data.Text.IO.putStr key + putStr key putStr "=" - Data.Text.IO.putStrLn value + putStrLn value putStrLn "" printFailures :: [Failure] -> IO () -printFailures fs = forM_ fs $ \(Failure loc msg) -> do +printFailures fs = forM_ fs $ \f -> do putStr " " - case loc of - Just loc' -> do - Data.Text.IO.putStr (locationFile loc') + case failureLocation f of + Just loc -> do + putStr (locationFile loc) putStr ":" - putStrLn (show (locationLine loc')) + case locationLine loc of + Just line -> putStrLn (show line) + Nothing -> putStrLn "" Nothing -> return () putStr " " - Data.Text.IO.putStr msg + putStr (failureMessage f) putStrLn "\n" diff --git a/lib/Test/Chell/Types.hs b/lib/Test/Chell/Types.hs --- a/lib/Test/Chell/Types.hs +++ b/lib/Test/Chell/Types.hs @@ -1,18 +1,62 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Test.Chell.Types where +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 + + , BuildSuite + , SuiteOrTest + , skipIf + , skipWhen + + , runTest + + , handleJankyIO + ) where import qualified Control.Exception import Control.Exception (SomeException, Handler(..), catches, throwIO) -import qualified Data.Text -import Data.Text (Text) import System.Timeout (timeout) -data Test = Test Text (TestOptions -> IO TestResult) +-- | 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 - show (Test name _) = "" + showsPrec d (Test name _) = showParen (d > 10) (showString "Test " . shows name) +-- | Define a test, with the given name and implementation. +test :: String -> (TestOptions -> IO TestResult) -> Test +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 { @@ -22,6 +66,9 @@ -- -- 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 @@ -29,40 +76,250 @@ -- -- 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. -- --- @ ---'testOptionSeed' defaultTestOptions = 0 ---'testOptionTimeout' defaultTestOptions = Nothing --- @ --- --- Since: 0.2.3 +-- >$ ghci +-- >Prelude> import Test.Chell +-- > +-- >Test.Chell> testOptionSeed defaultTestOptions +-- >0 +-- > +-- >Test.Chell> testOptionTimeout defaultTestOptions +-- >Nothing defaultTestOptions :: TestOptions defaultTestOptions = TestOptions { testOptionSeed = 0 , testOptionTimeout = Nothing } --- | @testName (Test name _) = name@ -testName :: Test -> Text -testName (Test name _) = name +-- | 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 node in a hierarchy of tests, similar to a directory in the +-- filesystem. Each suite has a name and a list of children, which are either +-- suites or tests. +data Suite = Suite String [SOT] + deriving (Show) + +data SOT + = SOT_Suite Suite + | SOT_Test Test + +instance Show SOT where + showsPrec d (SOT_Test t) = showsPrec d t + showsPrec d (SOT_Suite s) = showsPrec d s + +-- | See 'suite'. +class BuildSuite a where + addChildren :: Suite -> a + +instance BuildSuite Suite where + addChildren (Suite name cs) = Suite name (reverse cs) + +-- | See 'suite'. +class SuiteOrTest a where + toSOT :: a -> SOT + skipIf_ :: Bool -> a -> a + skipWhen_ :: IO Bool -> a -> a + +instance SuiteOrTest Suite where + toSOT = SOT_Suite + skipIf_ skip s@(Suite name children) = if skip + then Suite name (map skipSOT children) + else s + skipWhen_ p (Suite name children) = Suite name (map (skipWhenSOT p) children) + +instance SuiteOrTest Test where + toSOT = SOT_Test + 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) + +skipSOT :: SOT -> SOT +skipSOT (SOT_Test (Test name _)) = SOT_Test (Test name (\_ -> return TestSkipped)) +skipSOT (SOT_Suite (Suite name cs)) = SOT_Suite (Suite name (map skipSOT cs)) + +skipWhenSOT :: IO Bool -> SOT -> SOT +skipWhenSOT p (SOT_Suite s) = SOT_Suite (skipWhen_ p s) +skipWhenSOT p (SOT_Test t) = SOT_Test (skipWhen_ p t) + +-- | 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_ + +instance (SuiteOrTest t, BuildSuite s) => BuildSuite (t -> s) where + addChildren (Suite name cs) = \b -> addChildren (Suite name (toSOT b : cs)) + +-- | Define a new 'Suite', with the given name and children. +-- +-- The type of this function allows any number of children to be added, +-- without requiring them to be homogenous types. +-- +-- @ +--test_Addition :: Test +--test_Subtraction :: Test +--test_Show :: Test +-- +--tests_Math :: Suite +--tests_Math = 'suite' \"math\" +-- test_Addition +-- test_Subtraction +-- +--tests_Prelude :: Suite +--tests_Prelude = 'suite' \"prelude\" +-- tests_Math +-- test_Show +-- @ +suite :: BuildSuite a => String -> a +suite name = addChildren (Suite name []) + +-- | 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 (SOT_Suite s) = go prefix s + step prefix (SOT_Test (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 [(Text, Text)] -> IO TestResult +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 = Data.Text.pack str where + let hitTimeout = str where str = "Test timed out after " ++ show time ++ " milliseconds" Just time = testOptionTimeout opts @@ -74,7 +331,7 @@ return (TestAborted notes hitTimeout) Just (Left err) -> do notes <- getNotes - return (TestAborted notes (Data.Text.pack err)) + return (TestAborted notes err) try :: IO a -> IO (Either String a) try io = catches (fmap Right io) [Handler handleAsync, Handler handleExc] where @@ -83,57 +340,3 @@ handleExc :: SomeException -> IO (Either String a) handleExc exc = return (Left ("Test aborted due to exception: " ++ show exc)) - -data TestResult - = TestPassed [(Text, Text)] - | TestSkipped - | TestFailed [(Text, Text)] [Failure] - | TestAborted [(Text, Text)] Text - deriving (Show, Eq) - -data Failure = Failure (Maybe Location) Text - deriving (Show, Eq) - -data Location = Location - { locationFile :: Text - , locationModule :: Text - , locationLine :: Integer - } - deriving (Show, Eq) - -data ColorMode - = ColorModeAuto - | ColorModeAlways - | ColorModeNever - deriving (Enum) - --- | A tree of 'Test's; use the 'test' and 'suite' helper functions to build --- up a 'Suite'. -data Suite = Suite Text [Suite] - | SuiteTest Test - -instance Show Suite where - show s = "" - -test :: Test -> Suite -test = SuiteTest - -suite :: Text -> [Suite] -> Suite -suite = Suite - -suiteName :: Suite -> Text -suiteName (Suite name _) = name -suiteName (SuiteTest t) = testName t - --- | The full list of 'Test's contained within this 'Suite'. Each 'Test' --- is returned with its name modified to include the name of its parent --- 'Suite's. -suiteTests :: Suite -> [Test] -suiteTests = loop "" where - loop prefix s = let - name = if Data.Text.null prefix - then suiteName s - else Data.Text.concat [prefix, ".", suiteName s] - in case s of - Suite _ suites -> concatMap (loop name) suites - SuiteTest (Test _ io) -> [Test name io]