diff --git a/chell.cabal b/chell.cabal --- a/chell.cabal +++ b/chell.cabal @@ -1,5 +1,5 @@ name: chell -version: 0.2.2 +version: 0.2.3 license: MIT license-file: license.txt author: John Millikin @@ -10,8 +10,42 @@ bug-reports: mailto:jmillikin@gmail.com homepage: https://john-millikin.com/software/chell/ -synopsis: A quiet test runner +synopsis: A simple and intuitive library for automated testing. description: + Chell is a simple and intuitive library for automated testing. It natively + supports assertion-based testing, and can use companion libraries + such as @chell-quickcheck@ to support more complex testing strategies. + . + An example test suite, which verifies the behavior of artithmetic operators. + . + @ + {-\# LANGUAGE OverloadedStrings \#-} + {-\# LANGUAGE TemplateHaskell \#-} + . + import Test.Chell + . + test_Math :: Suite + test_Math = suite \"math\" [test_Addition, test_Subtraction] + . + test_Addition :: Suite + test_Addition = assertions \"addition\" $ do + $expect (equal (2 + 1) 3) + $expect (equal (1 + 2) 3) + . + test_Subtraction :: Suite + test_Subtraction = assertions \"subtraction\" $ do + $expect (equal (2 - 1) 1) + $expect (equal (1 - 2) (-1)) + . + main :: IO () + main = defaultMain [test_Math] + @ + . + @ + $ ghc --make chell-example.hs + $ ./chell-example + PASS: 2 tests run, 2 tests passed + @ source-repository head type: bazaar @@ -20,7 +54,7 @@ source-repository this type: bazaar location: https://john-millikin.com/branches/chell/0.2/ - tag: chell_0.2.2 + tag: chell_0.2.3 library hs-source-dirs: lib diff --git a/lib/Test/Chell.hs b/lib/Test/Chell.hs --- a/lib/Test/Chell.hs +++ b/lib/Test/Chell.hs @@ -25,11 +25,13 @@ , IsAssertion , Assertions , assertions + , assertionsTest , assert , expect , Test.Chell.fail , trace , note + , afterTest -- ** Assertions , equal @@ -56,6 +58,7 @@ , runTest , TestOptions + , defaultTestOptions , testOptionSeed , testOptionTimeout , TestResult (..) @@ -85,21 +88,6 @@ import Test.Chell.Main (defaultMain) import Test.Chell.Types --- | 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. --- --- Users may specify a seed using the @--seed@ command-line option. -testOptionSeed :: TestOptions -> Int -testOptionSeed = testOptionSeed_ - --- | An optional timeout, in millseconds. Tests which run longer than this --- timeout will be aborted. --- --- Users may specify a timeout using the @--timeout@ command-line option. -testOptionTimeout :: TestOptions -> Maybe Int -testOptionTimeout = testOptionTimeout_ - -- | Conditionally skip tests. Use this to avoid commenting out tests -- which are currently broken, or do not work on the current platform. -- @@ -153,7 +141,7 @@ then AssertionPassed else AssertionFailed "$assert: boolean assertion failed")) -type TestState = (IORef [(Text, Text)], [Failure]) +type TestState = (IORef [(Text, Text)], IORef [IO ()], [Failure]) newtype Assertions a = Assertions { unAssertions :: TestState -> IO (Maybe a, TestState) } instance Functor Assertions where @@ -185,26 +173,43 @@ -- $assert (equal 1 1) -- @ assertions :: Text -> Assertions a -> Suite -assertions name testm = test (Test name io) where - io opts = do - noteRef <- newIORef [] - - let getNotes = fmap reverse (readIORef noteRef) - - let getResult = do - res <- unAssertions testm (noteRef, []) - case res of - (_, (_, [])) -> do - notes <- getNotes - return (TestPassed notes) - (_, (_, fs)) -> do - notes <- getNotes - return (TestFailed notes (reverse fs)) - - handleJankyIO opts getResult getNotes +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. +assertionsTest :: Text -> Assertions a -> Test +assertionsTest 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 -> Text -> Assertions () -addFailure maybe_loc msg = Assertions $ \(notes, fs) -> do +addFailure maybe_loc msg = Assertions $ \(notes, afterTestRef, fs) -> do let loc = do th_loc <- maybe_loc return $ Location @@ -212,7 +217,7 @@ , locationModule = Data.Text.pack (TH.loc_module th_loc) , locationLine = toInteger (fst (TH.loc_start th_loc)) } - return (Just (), (notes, Failure loc msg : fs)) + return (Just (), (notes, afterTestRef, Failure loc msg : fs)) die :: Assertions a die = Assertions (\s -> return (Nothing, s)) @@ -238,10 +243,17 @@ -- | Attach metadata to a test run. This will be included in reports. note :: Text -> Text -> Assertions () -note key value = Assertions (\(notes, fs) -> do +note key value = Assertions (\(notes, afterTestRef, fs) -> do modifyIORef notes ((key, value) :) - return (Just (), (notes, fs))) + 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. +afterTest :: IO () -> Assertions () +afterTest io = Assertions (\(notes, ref, fs) -> do + modifyIORef ref (io :) + return (Just (), (notes, ref, fs))) + liftLoc :: TH.Loc -> TH.Q TH.Exp liftLoc loc = [| TH.Loc filename package module_ start end |] where filename = TH.loc_filename loc @@ -361,7 +373,7 @@ -- | Assert a value is greater than or equal to another. greaterEqual :: (Ord a, Show a) => a -> a -> Assertion -greaterEqual x y = pure (x > y) ("greaterEqual: " ++ show x ++ " is not greater than or equal to " ++ show y) +greaterEqual x y = pure (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 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 @@ -120,9 +120,9 @@ Just s -> return s Nothing -> randomIO - let testOptions = TestOptions - { testOptionSeed_ = seed - , testOptionTimeout_ = getTimeoutOpt options + let testOptions = defaultTestOptions + { testOptionSeed = seed + , testOptionTimeout = getTimeoutOpt options } let verbose = elem OptionVerbose options 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 @@ -14,11 +14,37 @@ show (Test name _) = "" data TestOptions = TestOptions - { testOptionSeed_ :: Int - , testOptionTimeout_ :: Maybe Int + { + + -- | 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 :: 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 :: Maybe Int } deriving (Show, Eq) +-- | Default test options. +-- +-- @ +--'testOptionSeed' defaultTestOptions = 0 +--'testOptionTimeout' defaultTestOptions = Nothing +-- @ +defaultTestOptions :: TestOptions +defaultTestOptions = TestOptions + { testOptionSeed = 0 + , testOptionTimeout = Nothing + } + -- | @testName (Test name _) = name@ testName :: Test -> Text testName (Test name _) = name @@ -30,13 +56,13 @@ handleJankyIO :: TestOptions -> IO TestResult -> IO [(Text, Text)] -> IO TestResult handleJankyIO opts getResult getNotes = do - let withTimeout = case testOptionTimeout_ opts of + let withTimeout = case testOptionTimeout opts of Just time -> timeout (time * 1000) Nothing -> fmap Just let hitTimeout = Data.Text.pack str where str = "Test timed out after " ++ show time ++ " milliseconds" - Just time = testOptionTimeout_ opts + Just time = testOptionTimeout opts let errorExc :: SomeException -> Text errorExc exc = Data.Text.pack ("Test aborted due to exception: " ++ show exc)