packages feed

chell 0.2.3 → 0.2.4

raw patch · 5 files changed

+346/−162 lines, 5 filesdep +ansi-terminaldep +optionsdep +system-filepathdep ~base

Dependencies added: ansi-terminal, options, system-filepath

Dependency ranges changed: base

Files

chell.cabal view
@@ -1,5 +1,5 @@ name: chell-version: 0.2.3+version: 0.2.4 license: MIT license-file: license.txt author: John Millikin <jmillikin@gmail.com>@@ -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
lib/Test/Chell.hs view
@@ -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.
lib/Test/Chell/Main.hs view
@@ -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
+ lib/Test/Chell/Output.hs view
@@ -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"
lib/Test/Chell/Types.hs view
@@ -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'.