diff --git a/chell.cabal b/chell.cabal --- a/chell.cabal +++ b/chell.cabal @@ -1,5 +1,5 @@ name: chell -version: 0.2.3 +version: 0.2.4 license: MIT license-file: license.txt author: John Millikin @@ -54,8 +54,12 @@ source-repository this type: bazaar location: https://john-millikin.com/branches/chell/0.2/ - tag: chell_0.2.3 + tag: chell_0.2.4 +flag color-output + description: Enable colored output in test results + default: True + library hs-source-dirs: lib ghc-options: -Wall -O2 @@ -63,15 +67,22 @@ build-depends: base >= 4.1 && < 5.0 , bytestring >= 0.9 + , options >= 0.1 && < 0.2 , patience >= 0.1 && < 0.2 , random >= 1.0 + , system-filepath >= 0.4 && < 0.5 , template-haskell >= 2.3 , text >= 0.7 , transformers >= 0.2 + if flag(color-output) + build-depends: + ansi-terminal >= 0.5 && < 0.6 + exposed-modules: Test.Chell other-modules: Test.Chell.Main + Test.Chell.Output Test.Chell.Types diff --git a/lib/Test/Chell.hs b/lib/Test/Chell.hs --- a/lib/Test/Chell.hs +++ b/lib/Test/Chell.hs @@ -28,10 +28,12 @@ , assertionsTest , assert , expect - , Test.Chell.fail + , die , trace , note , afterTest + , requireLeft + , requireRight -- ** Assertions , equal @@ -64,12 +66,15 @@ , TestResult (..) , Failure (..) , Location (..) + + -- * Deprecated + , Test.Chell.fail ) where import qualified Control.Applicative import qualified Control.Exception import Control.Exception (Exception) -import Control.Monad (ap, liftM, when) +import Control.Monad (ap, liftM) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Algorithm.Patience as Patience import qualified Data.ByteString.Char8 @@ -182,6 +187,8 @@ -- -- 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 noteRef <- newIORef [] @@ -219,22 +226,34 @@ } return (Just (), (notes, afterTestRef, Failure loc msg : fs)) -die :: Assertions a -die = Assertions (\s -> return (Nothing, s)) - -- | Cause a test to immediately fail, with a message. -- --- 'Test.Chell.fail' is a Template Haskell macro, to retain the source-file --- location from which it was used. Its effective type is: +-- 'die' is a Template Haskell macro, to retain the source-file location from +-- which it was used. Its effective type is: -- -- @ --- $fail :: 'Text' -> 'Assertions' a +-- $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)) |] + +dieAt :: TH.Loc -> Text -> 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 loc <- TH.location let qloc = liftLoc loc - [| \msg -> addFailure (Just $qloc) msg >> die |] + [| dieAt $qloc |] -- | Print a message from within a test. This is just a helper for debugging, -- so you don't have to import @Debug.Trace@. @@ -249,11 +268,61 @@ -- | 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 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 +-- @ +-- +-- Since: 0.2.4 +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 (Data.Text.pack ("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 +-- @ +-- +-- Since: 0.2.4 +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 (Data.Text.pack ("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 @@ -268,9 +337,9 @@ result <- liftIO io case result of AssertionPassed -> return () - AssertionFailed err -> do - addFailure (Just loc) err - when fatal die + AssertionFailed err -> if fatal + then dieAt loc err + else addFailure (Just loc) err -- | Run an 'Assertion'. If the assertion fails, the test will immediately -- fail. 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,10 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Chell.Main ( defaultMain ) where -import Control.Monad (forM, forM_, unless, when) +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 @@ -14,129 +15,108 @@ 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 +import qualified Filesystem.Path.CurrentOS as Path +import Options -data Option - = OptionHelp - | OptionVerbose - | OptionXmlReport FilePath - | OptionJsonReport FilePath - | OptionTextReport FilePath - | OptionSeed Int - | OptionTimeout Int - deriving (Show, Eq) +import Test.Chell.Output +import Test.Chell.Types -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" +defineOptions "MainOptions" $ do + option "optVerbose" (\o -> o + { optionShortFlags = ['v'] + , optionLongFlags = ["verbose"] + , optionType = optionTypeBool + , optionDefault = "false" + , optionDescription = "Print more output" + }) - , GetOpt.Option [] ["text-report"] - (GetOpt.ReqArg OptionTextReport "PATH") - "write a human-readable report" + pathOption "optXmlReport" "xml-report" "" + "Write a parsable report to a given path, in XML." + pathOption "optJsonReport" "json-report" "" + "Write a parsable report to a given path, in JSON." + pathOption "optTextReport" "text-report" "" + "Write a human-readable report to a given path." - , 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" + option "optSeed" (\o -> o + { optionLongFlags = ["seed"] + , optionType = optionTypeMaybe optionTypeInt + , optionDefault = "" + , optionDescription = "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" + option "optTimeout" (\o -> o + { optionLongFlags = ["timeout"] + , optionType = optionTypeMaybe optionTypeInt + , optionDefault = "" + , optionDescription = "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...]" + option "optColor" (\o -> o + { optionLongFlags = ["color"] + , optionType = optionTypeEnum ''ColorMode + [ ("always", ColorModeAlways) + , ("never", ColorModeNever) + , ("auto", ColorModeAuto) + ] + , 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. 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 +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 + IO.hPutStrLn IO.stderr "Test.Chell.defaultMain: Ignoring --timeout because it is too large." + return Nothing + else return (Just t) let testOptions = defaultTestOptions { testOptionSeed = seed - , testOptionTimeout = getTimeoutOpt options + , testOptionTimeout = timeout } - let verbose = elem OptionVerbose options + -- find which tests to run + let allTests = concatMap suiteTests suites + let 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 <- IO.hIsTerminalDevice IO.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 - printResult verbose t result + outputResult output t result return (t, result) - let reports = getReports options + -- 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 - when verbose $ do + when (optVerbose opts) $ do putStrLn ("Writing " ++ fmt ++ " report to " ++ show path) Data.ByteString.hPut h bytes @@ -154,54 +134,19 @@ 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 _ = [] +getReports :: MainOptions -> [(String, String, Report)] +getReports opts = concat [xml, json, text] where + xml = case optXmlReport opts of + p | Path.null p -> [] + p -> [(Path.encodeString p, "XML", xmlReport)] + json = case optJsonReport opts of + p | Path.null p -> [] + p -> [(Path.encodeString p, "JSON", jsonReport)] + text = case optTextReport opts of + p | Path.null p -> [] + p -> [(Path.encodeString p, "text", textReport)] jsonReport :: [(Test, TestResult)] -> Text jsonReport results = Writer.execWriter writer where diff --git a/lib/Test/Chell/Output.hs b/lib/Test/Chell/Output.hs new file mode 100644 --- /dev/null +++ b/lib/Test/Chell/Output.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} + +module Test.Chell.Output + ( Output(..) + , 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 +#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 ] " + Data.Text.IO.putStrLn (testName t) + +plainOutputResult :: Bool -> Test -> TestResult -> IO () +plainOutputResult v t (TestPassed _) = when v $ do + putStr "[ PASS ] " + Data.Text.IO.putStrLn (testName t) + putStrLn "" +plainOutputResult v t TestSkipped = when v $ do + putStr "[ SKIP ] " + Data.Text.IO.putStrLn (testName t) + putStrLn "" +plainOutputResult _ t (TestFailed notes fs) = do + putStr "[ FAIL ] " + Data.Text.IO.putStrLn (testName t) + printNotes notes + printFailures fs +plainOutputResult _ t (TestAborted notes msg) = do + putStr "[ ABORT ] " + Data.Text.IO.putStrLn (testName t) + printNotes notes + putStr " " + Data.Text.IO.putStr msg + putStrLn "\n" + +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 ] " + Data.Text.IO.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 " ] " + Data.Text.IO.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 " ] " + Data.Text.IO.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 " ] " + Data.Text.IO.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 " ] " + Data.Text.IO.putStrLn (testName t) + printNotes notes + putStr " " + Data.Text.IO.putStr msg + putStrLn "\n" +#endif + +printNotes :: [(Text, Text)] -> IO () +printNotes notes = unless (null notes) $ do + forM_ notes $ \(key, value) -> do + putStr " note: " + Data.Text.IO.putStr key + putStr "=" + Data.Text.IO.putStrLn value + putStrLn "" + +printFailures :: [Failure] -> IO () +printFailures fs = forM_ fs $ \(Failure loc msg) -> do + putStr " " + case loc of + Just loc' -> do + Data.Text.IO.putStr (locationFile loc') + putStr ":" + putStrLn (show (locationLine loc')) + Nothing -> return () + putStr " " + Data.Text.IO.putStr msg + 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 @@ -3,7 +3,7 @@ module Test.Chell.Types where import qualified Control.Exception -import Control.Exception (SomeException) +import Control.Exception (SomeException, Handler(..), catches, throwIO) import qualified Data.Text import Data.Text (Text) import System.Timeout (timeout) @@ -39,6 +39,8 @@ --'testOptionSeed' defaultTestOptions = 0 --'testOptionTimeout' defaultTestOptions = Nothing -- @ +-- +-- Since: 0.2.3 defaultTestOptions :: TestOptions defaultTestOptions = TestOptions { testOptionSeed = 0 @@ -64,19 +66,24 @@ 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) + tried <- withTimeout (try getResult) case tried of Just (Right ret) -> return ret Nothing -> do notes <- getNotes return (TestAborted notes hitTimeout) - Just (Left exc) -> do + Just (Left err) -> do notes <- getNotes - return (TestAborted notes (errorExc exc)) + return (TestAborted notes (Data.Text.pack 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)) + data TestResult = TestPassed [(Text, Text)] | TestSkipped @@ -93,6 +100,12 @@ , 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'.