diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/chell.cabal b/chell.cabal new file mode 100644 --- /dev/null +++ b/chell.cabal @@ -0,0 +1,36 @@ +name: chell +version: 0.1 +synopsis: Quiet test runner +license: MIT +license-file: license.txt +author: John Millikin +build-type: Simple +cabal-version: >= 1.6 +category: Testing +bug-reports: mailto:jmillikin@gmail.com +homepage: https://john-millikin.com/software/chell/ +tested-with: GHC==6.12.1 + +source-repository head + type: bazaar + location: https://john-millikin.com/software/chell/ + +library + ghc-options: -Wall + hs-source-dirs: src + + build-depends: + base >= 4 && < 5 + , bytestring >= 0.9 && < 0.10 + , patience >= 0.1 && < 0.2 + , random + , template-haskell >= 2.3 && < 2.6 + , text >= 0.7 + , transformers >= 0.2 && < 0.3 + + exposed-modules: + Test.Chell + + other-modules: + Test.Chell.Main + Test.Chell.Types diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,22 @@ +Copyright (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. diff --git a/src/Test/Chell.hs b/src/Test/Chell.hs new file mode 100644 --- /dev/null +++ b/src/Test/Chell.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Test.Chell + ( + + -- * Main + defaultMain + + -- * Test suites + , Suite + , suite + , suiteName + , suiteTests + , test + , skipIf + , skipWhen + + -- * Basic testing library + -- $doc-basic-testing + , Assertion (..) + , AssertionResult (..) + , IsAssertion + , Assertions + , assertions + , assert + , expect + , Test.Chell.fail + , trace + , note + + -- ** Assertions + , equal + , notEqual + , equalWithin + , just + , nothing + , throws + , throwsEq + , greater + , greaterEqual + , lesser + , lesserEqual + , sameItems + , equalItems + , IsText + , equalLines + + -- * Constructing tests + , Test (..) + , testName + , runTest + + , TestOptions + , testOptionSeed + , testOptionTimeout + , TestResult (..) + , Failure (..) + , Location (..) + ) 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.Algorithm.Patience as Patience +import qualified Data.ByteString.Char8 +import qualified Data.ByteString.Lazy.Char8 +import Data.Foldable (Foldable, foldMap) +import Data.List (foldl', intercalate, sort) +import Data.Maybe (isJust, isNothing) +import Data.IORef (IORef, newIORef, readIORef, modifyIORef) +import qualified Data.Text +import Data.Text (Text) +import qualified Data.Text.Lazy +import qualified Data.Text.IO + +import qualified Language.Haskell.TH as TH + +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 a test. Use this to avoid commenting out tests +-- which are currently broken, or do not work on the current platform. +-- +-- @ +--tests = 'suite' \"tests\" +-- [ 'test' ('skipIf' builtOnUnix test_WindowsSpecific) +-- ] +-- @ +-- +skipIf :: Bool -> Test -> Test +skipIf skip t@(Test name _) = if skip + then Test name (\_ -> return TestSkipped) + else t + +-- | Conditionally skip a test, depending on the result of a runtime check. +-- +-- @ +--tests = 'suite' \"tests\" +-- [ 'test' ('skipWhen' noNetwork test_PingGoogle) +-- ] +-- @ +skipWhen :: IO Bool -> Test -> Test +skipWhen p (Test name io) = Test name $ \options -> do + skipThis <- p + if skipThis + then return TestSkipped + else io options + +-- $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. + +newtype Assertion = Assertion (IO AssertionResult) + +data AssertionResult + = AssertionPassed + | AssertionFailed Text + +class IsAssertion a where + toAssertion :: a -> Assertion + +instance IsAssertion Assertion where + toAssertion = id + +instance IsAssertion Bool where + toAssertion x = Assertion (return (if x + then AssertionPassed + else AssertionFailed "$assert: boolean assertion failed")) + +type TestState = (IORef [(Text, Text)], [Failure]) +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 :: Text -> Assertions a -> Test +assertions name testm = 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 + +addFailure :: Maybe TH.Loc -> Bool -> Text -> Assertions () +addFailure maybe_loc fatal msg = Assertions $ \(notes, 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 ( if fatal then Nothing else Just () + , (notes, Failure loc msg : fs)) + +-- | Cause a test to immediately fail, with a message. +-- +-- 'fail' is a Template Haskell macro, to retain the source-file location +-- from which it was used. Its effective type is: +-- +-- @ +-- $fail :: 'Text' -> 'Assertions' () +-- @ +fail :: TH.Q TH.Exp -- :: Text -> Assertions () +fail = do + loc <- TH.location + let qloc = liftLoc loc + [| addFailure (Just $qloc) True |] + +-- | 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) + +-- | Attach metadata to a test run. This will be included in reports. +note :: Text -> Text -> Assertions () +note key value = Assertions (\(notes, fs) -> do + modifyIORef notes ((key, value) :) + return (Just (), (notes, fs))) + +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 + let Assertion io = toAssertion assertion + result <- liftIO io + case result of + AssertionPassed -> return () + AssertionFailed err -> addFailure (Just loc) fatal err + +-- | Run an 'Assertion'. If the assertion fails, the test will immediately +-- fail. +-- +-- '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 = 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). +-- +-- '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 = 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))) + +-- | Assert that two values are equal. +equal :: (Show a, Eq a) => a -> a -> Assertion +equal x y = pure (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 = pure (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 = pure + ((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 = pure (isJust x) ("just: received Nothing") + +-- | Assert that some value is @Nothing@. +nothing :: Maybe a -> Assertion +nothing x = pure (isNothing x) ("nothing: received Just") + +-- | 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 + either_exc <- Control.Exception.try io + 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")))) + +-- | 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 + either_exc <- Control.Exception.try io + 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")))) + +-- | Assert a value is greater than another. +greater :: (Ord a, Show a) => a -> a -> Assertion +greater x y = pure (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 = 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 +lesser x y = pure (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 = pure (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) -> pure 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. +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 = checkDiff (toLines x) (toLines y) where + checkDiff xs ys = case checkItems (Patience.diff xs ys) of + (same, diff) -> pure 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 = "equalLines: lines differ\n" ++ diff diff --git a/src/Test/Chell/Main.hs b/src/Test/Chell/Main.hs new file mode 100644 --- /dev/null +++ b/src/Test/Chell/Main.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Chell.Main + ( defaultMain + ) where + +import Control.Monad (forM, forM_, unless, when) +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 qualified System.Console.GetOpt as GetOpt +import System.Environment (getArgs, getProgName) +import System.Exit (exitSuccess, exitFailure) +import qualified System.IO as IO +import System.Random (randomIO) +import Text.Printf (printf) + +import Test.Chell.Types + +data Option + = OptionHelp + | OptionVerbose + | OptionXmlReport FilePath + | OptionJsonReport FilePath + | OptionTextReport FilePath + | OptionSeed Int + | OptionTimeout Int + deriving (Show, Eq) + +optionInfo :: [GetOpt.OptDescr Option] +optionInfo = + [ GetOpt.Option ['h'] ["help"] + (GetOpt.NoArg OptionHelp) + "show this help" + + , GetOpt.Option ['v'] ["verbose"] + (GetOpt.NoArg OptionVerbose) + "print more output" + + , GetOpt.Option [] ["xml-report"] + (GetOpt.ReqArg OptionXmlReport "PATH") + "write a parsable report to a file, in XML" + + , GetOpt.Option [] ["json-report"] + (GetOpt.ReqArg OptionJsonReport "PATH") + "write a parsable report to a file, in JSON" + + , GetOpt.Option [] ["text-report"] + (GetOpt.ReqArg OptionTextReport "PATH") + "write a human-readable report" + + , GetOpt.Option [] ["seed"] + (GetOpt.ReqArg (\s -> case parseInt s of + Just x -> OptionSeed x + Nothing -> error ("Failed to parse --seed value " ++ show s)) "SEED") + "the seed used for random numbers in (for example) quickcheck" + + , GetOpt.Option [] ["timeout"] + (GetOpt.ReqArg (\s -> case parseTimeout s of + Just x -> OptionTimeout x + Nothing -> error ("Failed to parse --timeout value " ++ show s)) "TIMEOUT") + "the maximum duration of a test, in milliseconds" + + ] + +parseInt :: String -> Maybe Int +parseInt s = case [x | (x, "") <- reads s] of + [x] -> Just x + _ -> Nothing + +parseTimeout :: String -> Maybe Int +parseTimeout s = do + msec <- parseInt s + if (toInteger msec) * 1000 > toInteger (maxBound :: Int) + then Nothing + else return msec + +getSeedOpt :: [Option] -> Maybe Int +getSeedOpt [] = Nothing +getSeedOpt ((OptionSeed s) : _) = Just s +getSeedOpt (_:os) = getSeedOpt os + +getTimeoutOpt :: [Option] -> Maybe Int +getTimeoutOpt [] = Nothing +getTimeoutOpt ((OptionTimeout s) : _) = Just s +getTimeoutOpt (_:os) = getTimeoutOpt os + +usage :: String -> String +usage name = "Usage: " ++ name ++ " [OPTION...]" + +-- | A simple default main function, which runs a list of tests and logs +-- statistics to stderr. +defaultMain :: [Suite] -> IO () +defaultMain suites = do + args <- getArgs + let (options, filters, optionErrors) = GetOpt.getOpt GetOpt.Permute optionInfo args + unless (null optionErrors) $ do + name <- getProgName + IO.hPutStrLn IO.stderr (concat optionErrors) + IO.hPutStrLn IO.stderr (GetOpt.usageInfo (usage name) optionInfo) + exitFailure + + when (OptionHelp `elem` options) $ do + name <- getProgName + putStrLn (GetOpt.usageInfo (usage name) optionInfo) + exitSuccess + + let allTests = concatMap suiteTests suites + let tests = if null filters + then allTests + else filter (matchesFilter filters) allTests + + seed <- case getSeedOpt options of + Just s -> return s + Nothing -> randomIO + + let testOptions = TestOptions + { testOptionSeed_ = seed + , testOptionTimeout_ = getTimeoutOpt options + } + + let verbose = elem OptionVerbose options + results <- forM tests $ \t -> do + result <- runTest t testOptions + printResult verbose t result + return (t, result) + + let reports = getReports options + forM_ reports $ \(path, fmt, toText) -> + IO.withBinaryFile path IO.WriteMode $ \h -> do + let text = toText results + let bytes = Data.Text.Encoding.encodeUtf8 text + when verbose $ do + putStrLn ("Writing " ++ fmt ++ " report to " ++ show path) + Data.ByteString.hPut h bytes + + let stats = resultStatistics results + let (_, _, failed, aborted) = stats + Data.Text.IO.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 + check t = any (matchName (testName t)) filters + matchName name f = f == name || Data.Text.isPrefixOf (Data.Text.append f ".") name + +printResult :: Bool -> Test -> TestResult -> IO () +printResult verbose t result = case result of + TestPassed _ -> when verbose $ do + Data.Text.IO.putStr (testName t) + putStrLn ": PASS" + TestSkipped -> when verbose $ do + Data.Text.IO.putStr (testName t) + putStrLn ": SKIPPED" + TestFailed notes fs -> do + putStrLn (replicate 70 '=') + Data.Text.IO.putStr (testName t) + putStrLn ": FAILED" + forM_ notes $ \(key, value) -> do + putStr "\t" + Data.Text.IO.putStr key + putStr "=" + Data.Text.IO.putStrLn value + putStrLn (replicate 70 '=') + forM_ fs $ \(Failure loc msg) -> do + case loc of + Just loc' -> do + Data.Text.IO.putStr (locationFile loc') + putStr ":" + putStrLn (show (locationLine loc')) + Nothing -> return () + Data.Text.IO.putStr msg + putStr "\n\n" + TestAborted notes msg -> do + putStrLn (replicate 70 '=') + Data.Text.IO.putStr (testName t) + putStrLn ": ABORTED" + forM_ notes $ \(key, value) -> do + putStr "\t" + Data.Text.IO.putStr key + putStr "=" + Data.Text.IO.putStrLn value + putStrLn (replicate 70 '=') + Data.Text.IO.putStr msg + putStr "\n\n" + +type Report = [(Test, TestResult)] -> Text + +getReports :: [Option] -> [(FilePath, String, Report)] +getReports = concatMap step where + step (OptionXmlReport path) = [(path, "XML", xmlReport)] + step (OptionJsonReport path) = [(path, "JSON", jsonReport)] + step (OptionTextReport path) = [(path, "text", textReport)] + step _ = [] + +jsonReport :: [(Test, TestResult)] -> Text +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 $ \(Failure loc msg) -> do + tell "{\"message\": \"" + tell (escapeJSON msg) + tell "\"" + case loc of + Just loc' -> do + tell ", \"location\": {\"module\": \"" + tell (escapeJSON (locationModule loc')) + tell "\", \"file\": \"" + tell (escapeJSON (locationFile loc')) + tell "\", \"line\": " + tell (pack (show (locationLine loc'))) + 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 "}" + + escapeJSON = Data.Text.concatMap (\c -> case c of + '"' -> "\\\"" + '\\' -> "\\\\" + _ | ord c <= 0x1F -> pack (printf "\\u%04X" (ord c)) + _ -> Data.Text.singleton 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)] -> Text +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 $ \(Failure loc msg) -> do + tell "\t\t do + tell "'>\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" + + escapeXML = Data.Text.concatMap (\c -> case c of + '&' -> "&" + '<' -> "<" + '>' -> ">" + '"' -> """ + '\'' -> "'" + _ -> Data.Text.singleton c) + + tellNotes notes = forM_ notes $ \(key, value) -> do + tell "\t\t\n" + +textReport :: [(Test, TestResult)] -> Text +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 (Data.Text.replicate 70 "=") + tell "\n" + tell "PASSED: " + tell (testName t) + tell "\n" + tellNotes notes + tell "\n\n" + TestSkipped -> do + tell (Data.Text.replicate 70 "=") + tell "\n" + tell "SKIPPED: " + tell (testName t) + tell "\n\n" + TestFailed notes fs -> do + tell (Data.Text.replicate 70 "=") + tell "\n" + tell "FAILED: " + tell (testName t) + tell "\n" + tellNotes notes + tell (Data.Text.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'))) + tell "\n" + Nothing -> return () + tell msg + tell "\n\n" + TestAborted notes msg -> do + tell (Data.Text.replicate 70 "=") + tell "\n" + tell "ABORTED: " + tell (testName t) + tell "\n" + tellNotes notes + tell (Data.Text.replicate 70 "-") + tell "\n" + tell msg + tell "\n\n" + + tellNotes notes = forM_ notes $ \(key, value) -> do + tell key + tell "=" + tell value + tell "\n" + +formatResultStatistics :: (Integer, Integer, Integer, Integer) -> Text +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 pack (comma ++ "1 test " ++ what) + else pack (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)) diff --git a/src/Test/Chell/Types.hs b/src/Test/Chell/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/Chell/Types.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Chell.Types where + +import qualified Control.Exception +import Control.Exception (SomeException) +import qualified Data.Text +import Data.Text (Text) +import System.Timeout (timeout) + +data Test = Test Text (TestOptions -> IO TestResult) + +instance Show Test where + show (Test name _) = "" + +data TestOptions = TestOptions + { testOptionSeed_ :: Int + , testOptionTimeout_ :: Maybe Int + } + deriving (Show, Eq) + +-- | @testName (Test name _) = name@ +testName :: Test -> Text +testName (Test name _) = name + +-- | 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 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 + str = "Test timed out after " ++ show time ++ " milliseconds" + Just time = testOptionTimeout_ opts + + let errorExc :: SomeException -> Text + errorExc exc = Data.Text.pack ("Test aborted due to exception: " ++ show exc) + + tried <- withTimeout (Control.Exception.try getResult) + case tried of + Just (Right ret) -> return ret + Nothing -> do + notes <- getNotes + return (TestAborted notes hitTimeout) + Just (Left exc) -> do + notes <- getNotes + return (TestAborted notes (errorExc 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) + +-- | 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]