diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,13 @@ Changes ======= +Version 3.1.7 +------------- + +* Add feature to disable certain tests, still showing them in the UI + but not running them. +* Fix a concurrency issue in the interactive test runner. + Version 3.1.6 ------------- diff --git a/Test/Tasty/Silver/Filter.hs b/Test/Tasty/Silver/Filter.hs --- a/Test/Tasty/Silver/Filter.hs +++ b/Test/Tasty/Silver/Filter.hs @@ -8,10 +8,11 @@ -- | Regex filtering for test trees. module Test.Tasty.Silver.Filter ( filterWithRegex - , filterWithRegex1 + , checkRF , RegexFilter (..) , IncludeFilters (..) , ExcludeFilters (..) + , TestPath ) where @@ -23,6 +24,7 @@ import Data.Typeable import Data.Maybe import Data.Monoid +import qualified Data.List as L #if __GLASGOW_HASKELL__ < 708 import Data.Foldable (foldMap) #endif @@ -33,6 +35,8 @@ import qualified Text.Regex.TDFA.String as RS import qualified Text.Regex.TDFA as R +type TestPath = String + -- we have to store the regex as String, as there is no Typeable instance -- for the Regex data type with GHC < 7.8 data RegexFilter @@ -40,27 +44,16 @@ | RFExclude String -- exclude tests that match deriving (Typeable) +-- | Tests to completely exlucde, treating them +-- like they do not exist. newtype ExcludeFilters = ExcludeFilters [RegexFilter] deriving (Typeable) +-- | Tests to completely include, treating all +-- other tests like they do not exist. newtype IncludeFilters = IncludeFilters [RegexFilter] deriving (Typeable) -compileRegex :: String -> Maybe RS.Regex -compileRegex = either (const Nothing) Just . RS.compile R.defaultCompOpt R.defaultExecOpt - -parseFilter :: forall v . IsOption v => (String -> RegexFilter) -> ([RegexFilter] -> v) -> Parser v -parseFilter mkRF mkV = mkV <$> many ( option parse ( long name <> help helpString)) - where - name = untag (optionName :: Tagged v String) - helpString = untag (optionHelp :: Tagged v String) - parse = (str >>= - either (\err -> readerError $ "Could not parse " ++ name ++ ": " ++ err) (\_ -> mkRF <$> str) - <$> RS.compile R.defaultCompOpt R.defaultExecOpt) - -parseValue1 :: (String -> RegexFilter) -> String -> Maybe [RegexFilter] -parseValue1 f x = fmap (const $ [f x]) $ compileRegex x - instance IsOption ExcludeFilters where defaultValue = ExcludeFilters [] parseValue = fmap ExcludeFilters . parseValue1 RFExclude @@ -75,25 +68,57 @@ optionHelp = return "Include only tests matching a regex (experimental)." optionCLParser = parseFilter RFInclude IncludeFilters +compileRegex :: String -> Maybe RS.Regex +compileRegex = either (const Nothing) Just . RS.compile R.defaultCompOpt R.defaultExecOpt +parseFilter :: forall v . IsOption v => (String -> RegexFilter) -> ([RegexFilter] -> v) -> Parser v +parseFilter mkRF mkV = mkV <$> many ( option parse ( long name <> help helpString)) + where + name = untag (optionName :: Tagged v String) + helpString = untag (optionHelp :: Tagged v String) + parse = (str >>= + either (\err -> readerError $ "Could not parse " ++ name ++ ": " ++ err) (\_ -> mkRF <$> str) + <$> RS.compile R.defaultCompOpt R.defaultExecOpt) + +parseValue1 :: (String -> RegexFilter) -> String -> Maybe [RegexFilter] +parseValue1 f x = fmap (const $ [f x]) $ compileRegex x + filterWithRegex :: OptionSet -> TestTree -> TestTree -filterWithRegex opts tree = foldl (filterWithRegex1 opts) tree (excRgxs ++ incRgxs) +filterWithRegex opts = filterWithPred (checkRF True $ excRgxs ++ incRgxs) where ExcludeFilters excRgxs = lookupOption opts IncludeFilters incRgxs = lookupOption opts -filterWithRegex1 :: OptionSet -> TestTree -> RegexFilter -> TestTree -filterWithRegex1 _ tree rf = fromMaybe emptyTest (filter' "/" tree) - where x y = x ++ "/" ++ y +-- | Check if the given path should be kept using regex filters. +-- A Tree leaf is retained if the following conditions +-- are met: +-- 1. At least one RFInclude matches. +-- 2. No RFExclude filter matches. +checkRF :: Bool -- ^ If true, ignore 1. condition if no RFInclude is given. + -> [RegexFilter] + -> TestPath -> Bool +checkRF ignNoInc rf tp = + ((null incRgxs && ignNoInc) || any regexMatches incRgxs) + && (not $ any regexMatches excRgxs) + where (incRgxs, excRgxs) = L.partition (isInclude) rf + isInclude (RFInclude _) = True + isInclude (RFExclude _) = False - prd = case rf of - RFInclude rgx -> R.matchTest (fromJust $ compileRegex rgx) - RFExclude rgx -> not . R.matchTest (fromJust $ compileRegex rgx) + -- | Returns if the regex matches the test path. + -- Does NOT differentiate between exclude and include + -- filters! + regexMatches :: RegexFilter -> Bool + regexMatches (RFInclude rgx) = R.matchTest (fromJust $ compileRegex rgx) tp + regexMatches (RFExclude rgx) = R.matchTest (fromJust $ compileRegex rgx) tp - filter' :: String -> TestTree -> Maybe TestTree + +filterWithPred :: (TestPath -> Bool) -> TestTree -> TestTree +filterWithPred prd tree = fromMaybe emptyTest (filter' "/" tree) + where x y = x ++ "/" ++ y + + filter' :: TestPath -> TestTree -> Maybe TestTree filter' pth (SingleTest n t) = if prd (pth n) then Just $ SingleTest n t else Nothing - filter' pth (TestGroup n ts) = if prd pth' then Just $ TestGroup n (catMaybes $ map (filter' pth') ts) else Nothing - where pth' = pth n + filter' pth (TestGroup n ts) = Just $ TestGroup n (catMaybes $ map (filter' $ pth n) ts) filter' pth (PlusTestOptions o t) = PlusTestOptions o <$> filter' pth t -- we don't know at tree construction time what the tree wrapped inside an AskOptions/WithResource -- is going to look like. We always return something, and just return an empty test group diff --git a/Test/Tasty/Silver/Interactive.hs b/Test/Tasty/Silver/Interactive.hs --- a/Test/Tasty/Silver/Interactive.hs +++ b/Test/Tasty/Silver/Interactive.hs @@ -11,6 +11,7 @@ ( -- * Command line helpers defaultMain + , defaultMain1 -- * The ingredient , interactiveTests @@ -50,7 +51,7 @@ import Text.Printf import qualified Data.Text as T import Data.Text.Encoding -import Options.Applicative +import Options.Applicative hiding (Failure, Success) import System.Process.ByteString as PS import System.Process import qualified Data.ByteString as BS @@ -58,16 +59,23 @@ import System.IO.Temp import System.FilePath import Test.Tasty.Providers -import qualified Data.Map as M import System.Console.ANSI import qualified System.Process.Text as PTL +type DisabledTests = TestPath -> Bool -- | Like @defaultMain@ from the main tasty package, but also includes the -- golden test management capabilities. defaultMain :: TestTree -> IO () -defaultMain = defaultMainWithIngredients [listingTests, interactiveTests] +defaultMain = defaultMain1 [] + +defaultMain1 :: ([RegexFilter]) -> TestTree -> IO () +defaultMain1 filters = defaultMainWithIngredients + [ listingTests + , interactiveTests (checkRF False filters) + ] + newtype Interactive = Interactive Bool deriving (Eq, Ord, Typeable) instance IsOption Interactive where @@ -77,15 +85,28 @@ optionHelp = return "Run tests in interactive mode." optionCLParser = flagCLParser (Just 'i') (Interactive True) +data ResultType = RTSuccess | RTFail | RTIgnore + deriving (Eq) -data ResultStatus = RPass | RFail | RMismatch GoldenResultI +data FancyTestException + = Mismatch GoldenResultI + | Disabled + deriving (Show, Typeable) -type GoldenStatus = GoldenResultI +instance Exception FancyTestException -type GoldenStatusMap = TVar (M.Map TestName GoldenStatus) +getResultType :: Result -> ResultType +getResultType (Result { resultOutcome = Success}) = RTSuccess +getResultType (Result { resultOutcome = (Failure (TestThrewException e))}) = + case fromException e of + Just Disabled -> RTIgnore + _ -> RTFail +getResultType (Result { resultOutcome = (Failure _)}) = RTFail -interactiveTests :: Ingredient -interactiveTests = TestManager + +interactiveTests :: DisabledTests + -> Ingredient +interactiveTests dis = TestManager [ Option (Proxy :: Proxy Interactive) , Option (Proxy :: Proxy HideSuccesses) , Option (Proxy :: Proxy UseColor) @@ -94,29 +115,30 @@ , Option (Proxy :: Proxy IncludeFilters) ] $ \opts tree -> - Just $ runTestsInteractive opts (filterWithRegex opts tree) + Just $ runTestsInteractive dis opts (filterWithRegex opts tree) -runSingleTest :: IsTest t => GoldenStatusMap -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result -runSingleTest gs n opts t cb = do +runSingleTest :: IsTest t => DisabledTests -> TestPath -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result +runSingleTest dis tp _ _ _ _ | dis tp = + return $ (testFailed "") + { resultOutcome = (Failure $ TestThrewException $ toException Disabled) } +runSingleTest _ _ _ opts t cb = do case (cast t :: Maybe Golden) of Nothing -> run opts t cb Just g -> do - (r, gr) <- runGolden g -- we may be in a different thread here than the main ui. -- force evaluation of actual value here, as we have to evaluate it before -- leaving this test. gr' <- forceGoldenResult gr - atomically $ modifyTVar gs (M.insert n gr') - return r - + case gr' of + GREqual -> return r + grd -> return $ r { resultOutcome = (Failure $ TestThrewException $ toException $ Mismatch grd) } -- | A simple console UI -runTestsInteractive :: OptionSet -> TestTree -> IO Bool -runTestsInteractive opts tests = do - gmap <- newTVarIO M.empty - let tests' = wrapRunTest (runSingleTest gmap) tests +runTestsInteractive :: DisabledTests -> OptionSet -> TestTree -> IO Bool +runTestsInteractive dis opts tests = do + let tests' = wrapRunTest (runSingleTest dis) tests r <- launchTestTree opts tests' $ \smap -> do @@ -140,10 +162,10 @@ stats <- case () of { _ | hideSuccesses && isTerm -> - consoleOutputHidingSuccesses outp smap gmap + consoleOutputHidingSuccesses outp smap | hideSuccesses && not isTerm -> - streamOutputHidingSuccesses outp smap gmap - | otherwise -> consoleOutput outp smap gmap + streamOutputHidingSuccesses outp smap + | otherwise -> consoleOutput outp smap } return $ \time -> do @@ -235,7 +257,7 @@ = HandleTest {- test name, used for golden lookup #-} (TestName) {- print test name -} (IO ()) - {- print test result -} ((Result, ResultStatus) -> IO Statistics) + {- print test result -} (Result -> IO Statistics) | PrintHeading (IO ()) TestOutput | Skip | Seq TestOutput TestOutput @@ -267,92 +289,110 @@ printTestName = printf "%s%s: %s" (indent level) name align hsep = putStrLn (replicate 40 '=') - printResultLine success time forceTime = do + printResultLine result forceTime = do -- use an appropriate printing function let - printFn = - if success - then ok - else fail - if success - then printFn "OK" - else printFn "FAIL" + resTy = getResultType result + printFn = case resTy of + RTSuccess -> ok + RTIgnore -> warn + RTFail -> fail + case resTy of + RTSuccess -> printFn "OK" + RTIgnore -> printFn "DISABLED" + RTFail -> printFn "FAIL" -- print time only if it's significant - when (time >= 0.01 || forceTime) $ - printFn (printf " (%.2fs)" time) + when (resultTime result >= 0.01 || forceTime) $ + printFn (printf " (%.2fs)" $ resultTime result) printFn "\n" - handleTestResult (result, resultStatus) = do + handleTestResult result = do -- non-interactive mode. Uses different order of printing, -- as using the interactive layout doesn't go that well -- with printing the diffs to stdout. -- - printResultLine (resultSuccessful result) (resultTime result) True + printResultLine result True rDesc <- formatMessage $ resultDescription result - when (not $ null rDesc) $ - (if resultSuccessful result then infoOk else infoFail) $ + when (not $ null rDesc) $ (case getResultType result of + RTSuccess -> infoOk + RTIgnore -> infoWarn + RTFail -> infoFail) $ printf "%s%s\n" pref (formatDesc (level+1) rDesc) - stat' <- case resultStatus of - RMismatch (GRNoGolden a shw _) -> do - infoFail $ printf "%sActual value is:\n" pref - let a' = runIdentity a - shw' <- shw a' - hsep - printValue name shw' - hsep - return ( mempty { statFailures = 1 } ) - RMismatch (GRDifferent _ _ diff _) -> do - infoFail $ printf "%sDiff between actual and golden value:\n" pref - hsep - printDiff name diff - hsep - return ( mempty { statFailures = 1 } ) - RMismatch _ -> error "Impossible case!" - RPass -> return ( mempty { statSuccesses = 1 } ) - RFail -> return ( mempty { statFailures = 1 } ) + stat' <- case resultOutcome result of + Failure (TestThrewException e) -> + case fromException e of + Just (Mismatch (GRNoGolden a shw _)) -> do + infoFail $ printf "%sActual value is:\n" pref + let a' = runIdentity a + shw' <- shw a' + hsep + printValue name shw' + hsep + return ( mempty { statFailures = 1 } ) + Just (Mismatch (GRDifferent _ _ diff _)) -> do + infoFail $ printf "%sDiff between actual and golden value:\n" pref + hsep + printDiff name diff + hsep + return ( mempty { statFailures = 1 } ) + Just (Mismatch _) -> error "Impossible case!" + Just Disabled -> return ( mempty { statDisabled = 1 } ) + Nothing -> return ( mempty { statFailures = 1 } ) + Failure _ -> return ( mempty { statFailures = 1 } ) + Success -> return ( mempty { statSuccesses = 1 } ) return stat' - handleTestResultInteractive (result, resultStatus) = do - (result', stat') <- case resultStatus of - RMismatch (GRNoGolden a shw upd) -> do - printf "Golden value missing. Press to show actual value.\n" - _ <- getLine - let a' = runIdentity a - shw' <- shw a' - showValue name shw' - isUpd <- tryAccept pref name upd a' + handleTestResultInteractive result = do + (result', stat') <- case (resultOutcome result) of + Failure (TestThrewException e) -> + case fromException e of + Just (Mismatch (GRNoGolden a shw upd)) -> do + printf "Golden value missing. Press to show actual value.\n" + _ <- getLine + let a' = runIdentity a + shw' <- shw a' + showValue name shw' + isUpd <- tryAccept pref name upd a' - return ( - if isUpd - then ( testPassed "Created golden value." - , mempty { statCreatedGolden = 1 } ) - else ( testFailed "Golden value missing." - , mempty { statFailures = 1 } ) - ) - RMismatch (GRDifferent _ a diff upd) -> do - printf "Golden value differs from actual value.\n" - showDiff name diff - isUpd <- tryAccept pref name upd a - return ( - if isUpd - then ( testPassed "Updated golden value." - , mempty { statUpdatedGolden = 1 } ) - else ( testFailed "Golden value does not match actual output." - , mempty { statFailures = 1 } ) - ) - RMismatch _ -> error "Impossible case!" - RPass -> return (result, mempty { statSuccesses = 1 }) - RFail -> return (result, mempty { statFailures = 1 }) - rDesc <- formatMessage $ resultDescription result' + return ( + if isUpd + then ( testPassed "Created golden value." + , mempty { statCreatedGolden = 1 } ) + else ( testFailed "Golden value missing." + , mempty { statFailures = 1 } ) + ) + Just (Mismatch (GRDifferent _ a diff upd)) -> do + printf "Golden value differs from actual value.\n" + showDiff name diff + isUpd <- tryAccept pref name upd a + return ( + if isUpd + then ( testPassed "Updated golden value." + , mempty { statUpdatedGolden = 1 } ) + else ( testFailed "Golden value does not match actual output." + , mempty { statFailures = 1 } ) + ) + Just (Mismatch _) -> error "Impossible case!" + Just Disabled -> return + ( result + , mempty { statDisabled = 1 } ) + Nothing -> return (result, mempty {statFailures = 1}) + Success -> return (result, mempty { statSuccesses = 1 }) + Failure _ -> return (result, mempty { statFailures = 1 }) - printResultLine (resultSuccessful result') (resultTime result) False + let result'' = result' { resultTime = resultTime result } - when (not $ null rDesc) $ - (if resultSuccessful result' then infoOk else infoFail) $ + printResultLine result'' False + + rDesc <- formatMessage $ resultDescription result'' + when (not $ null rDesc) $ (case getResultType result'' of + RTSuccess -> infoOk + RTIgnore -> infoWarn + RTFail -> infoFail) $ printf "%s%s\n" pref (formatDesc (level+1) rDesc) return stat' @@ -379,18 +419,21 @@ foldTestOutput :: (?colors :: Bool, Monoid b) - => (IO () -> IO (Result, ResultStatus) - -> ((Result, ResultStatus) -> IO Statistics) + => (IO () -> IO Result + -> (Result -> IO Statistics) -> b) -> (IO () -> b -> b) - -> TestOutput -> StatusMap -> GoldenStatusMap -> b -foldTestOutput foldTest foldHeading outputTree smap gmap = + -> TestOutput -> StatusMap -> b +foldTestOutput foldTest foldHeading outputTree smap = flip evalState 0 $ getApp $ go outputTree where - go (HandleTest nm printName handleResult) = Ap $ do + go (HandleTest _ printName handleResult) = Ap $ do ix <- get put $! ix + 1 let - readStatusVar = getResultWithGolden smap gmap nm ix + statusVar = + fromMaybe (error "internal error: index out of bounds") $ + IntMap.lookup ix smap + readStatusVar = getResultFromTVar statusVar return $ foldTest printName readStatusVar handleResult go (PrintHeading printName printBody) = Ap $ foldHeading printName <$> getApp (go printBody) @@ -403,9 +446,9 @@ -- TestOutput modes -------------------------------------------------- -- {{{ -consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO Statistics -consoleOutput outp smap gmap = - getApp . fst $ foldTestOutput foldTest foldHeading outp smap gmap +consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics +consoleOutput outp smap = + getApp . fst $ foldTestOutput foldTest foldHeading outp smap where foldTest printName getResult handleResult = (Ap $ do @@ -420,15 +463,15 @@ return stats , Any nonempty ) -consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO Statistics -consoleOutputHidingSuccesses outp smap gmap = - snd <$> (getApp $ foldTestOutput foldTest foldHeading outp smap gmap) +consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics +consoleOutputHidingSuccesses outp smap = + snd <$> (getApp $ foldTestOutput foldTest foldHeading outp smap) where foldTest printName getResult handleResult = Ap $ do _ <- printName r <- getResult - if resultSuccessful (fst r) + if resultSuccessful r then do clearThisLine return (Any False, mempty { statSuccesses = 1 }) @@ -446,15 +489,15 @@ clearAboveLine = do cursorUpLine 1; clearThisLine clearThisLine = do clearLine; setCursorColumn 0 -streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> GoldenStatusMap -> IO Statistics -streamOutputHidingSuccesses outp smap gmap = +streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO Statistics +streamOutputHidingSuccesses outp smap = snd <$> (flip evalStateT [] . getApp $ - foldTestOutput foldTest foldHeading outp smap gmap) + foldTestOutput foldTest foldHeading outp smap) where foldTest printName getResult handleResult = Ap $ do r <- liftIO $ getResult - if resultSuccessful (fst r) + if resultSuccessful r then return (Any False, mempty { statSuccesses = 1 }) else do stack <- get @@ -490,11 +533,12 @@ , statUpdatedGolden :: !Int , statCreatedGolden :: !Int , statFailures :: !Int + , statDisabled :: !Int } instance Monoid Statistics where - Statistics s1 ug1 cg1 f1 `mappend` Statistics s2 ug2 cg2 f2 = Statistics (s1 + s2) (ug1 + ug2) (cg1 + cg2) (f1 + f2) - mempty = Statistics 0 0 0 0 + Statistics a1 b1 c1 d1 e1 `mappend` Statistics a2 b2 c2 d2 e2 = Statistics (a1 + a2) (b1 + b2) (c1 + c2) (d1 + d2) (e1 + e2) + mempty = Statistics 0 0 0 0 0 printStatistics :: (?colors :: Bool) => Statistics -> Time -> IO () printStatistics st time = do @@ -504,6 +548,7 @@ when (statCreatedGolden st > 0) (printf "Created %d golden values.\n" (statCreatedGolden st)) when (statUpdatedGolden st > 0) (printf "Updated %d golden values.\n" (statUpdatedGolden st)) + when (statDisabled st > 0) (printf "Ignored %d disabled tests.\n" (statDisabled st)) case statFailures st of 0 -> do @@ -588,7 +633,7 @@ -------------------------------------------------- -- {{{ -getResultWithGolden :: StatusMap -> GoldenStatusMap -> TestName -> Int -> IO (Result, ResultStatus) +{-getResultWithGolden :: StatusMap -> GoldenStatusMap -> TestName -> Int -> IO (Result, ResultStatus) getResultWithGolden smap gmap nm ix = do r <- getResultFromTVar statusVar @@ -597,10 +642,12 @@ Just g@(GRDifferent {}) -> return (r, RMismatch g) Just g@(GRNoGolden {}) -> return (r, RMismatch g) _ | resultSuccessful r -> return (r, RPass) + _ | resultOutcome r _ | otherwise -> return (r, RFail) where statusVar = fromMaybe (error "internal error: index out of bounds") $ IntMap.lookup ix smap +-} getResultFromTVar :: TVar Status -> IO Result getResultFromTVar statusVar = do @@ -610,6 +657,8 @@ Done r -> return r _ -> retry + + -- }}} -------------------------------------------------- @@ -674,10 +723,12 @@ Maximum x -> x -- (Potentially) colorful output -ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO () -fail = output BoldIntensity Vivid Red +ok, warn, fail, infoOk, infoWarn, infoFail :: (?colors :: Bool) => String -> IO () ok = output NormalIntensity Dull Green +warn = output NormalIntensity Dull Yellow +fail = output BoldIntensity Vivid Red infoOk = output NormalIntensity Dull White +infoWarn = output NormalIntensity Dull White infoFail = output NormalIntensity Dull Red output diff --git a/Test/Tasty/Silver/Interactive/Run.hs b/Test/Tasty/Silver/Interactive/Run.hs --- a/Test/Tasty/Silver/Interactive/Run.hs +++ b/Test/Tasty/Silver/Interactive/Run.hs @@ -21,11 +21,23 @@ run opts (CustomTestExec t r) cb = r opts t cb testOptions = retag $ (testOptions :: Tagged t [OptionDescription]) +type TestPath = String -- | Provide new test run function wrapping the existing tests. -wrapRunTest :: (forall t . IsTest t => TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result) -> TestTree -> TestTree -wrapRunTest f (SingleTest n t) = SingleTest n (CustomTestExec t (f n)) -wrapRunTest f (TestGroup n ts) = TestGroup n (fmap (wrapRunTest f) ts) -wrapRunTest f (PlusTestOptions o t) = PlusTestOptions o (wrapRunTest f t) -wrapRunTest f (WithResource r t) = WithResource r (\x -> wrapRunTest f (t x)) -wrapRunTest f (AskOptions t) = AskOptions (\o -> wrapRunTest f (t o)) +wrapRunTest :: (forall t . IsTest t => TestPath -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result) + -> TestTree + -> TestTree +wrapRunTest = wrapRunTest' "/" + +wrapRunTest' :: TestPath + -> (forall t . IsTest t => TestPath -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result) + -> TestTree + -> TestTree +wrapRunTest' tp f (SingleTest n t) = SingleTest n (CustomTestExec t (f (tp n) n)) +wrapRunTest' tp f (TestGroup n ts) = TestGroup n (fmap (wrapRunTest' (tp n) f) ts) +wrapRunTest' tp f (PlusTestOptions o t) = PlusTestOptions o (wrapRunTest' tp f t) +wrapRunTest' tp f (WithResource r t) = WithResource r (\x -> wrapRunTest' tp f (t x)) +wrapRunTest' tp f (AskOptions t) = AskOptions (\o -> wrapRunTest' tp f (t o)) + +() :: TestPath -> TestPath -> TestPath +a b = a ++ "/" ++ b diff --git a/Test/Tasty/Silver/Internal.hs b/Test/Tasty/Silver/Internal.hs --- a/Test/Tasty/Silver/Internal.hs +++ b/Test/Tasty/Silver/Internal.hs @@ -117,3 +117,8 @@ return $ GRNoGolden (Identity act') shw upd (GRDifferent a b c d) -> return $ GRDifferent a b c d (GREqual) -> return GREqual + +instance forall m . Show (GoldenResult' m) where + show GREqual = "GREqual" + show (GRDifferent {}) = "GRDifferent" + show (GRNoGolden {}) = "GRNoGolden" diff --git a/tasty-silver.cabal b/tasty-silver.cabal --- a/tasty-silver.cabal +++ b/tasty-silver.cabal @@ -1,12 +1,17 @@ name: tasty-silver -version: 3.1.6 -synopsis: Golden tests support for tasty. Fork of tasty-golden. +version: 3.1.7 +synopsis: A fancy test runner, including support for golden tests. description: - This package provides support for «golden testing». + This package provides a fancy test runner and support for «golden testing». A golden test is an IO action that writes its result to a file. To pass the test, this output file should be identical to the corresponding «golden» file, which contains the correct result for the test. + + The test runner allows filtering tests using regexes, and to interactively + inspect the result of golden tests. + + This package is a heavily extended fork of tasty-golden. license: MIT license-file: LICENSE diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -6,6 +6,7 @@ import Test.Tasty.Silver.Advanced import Test.Tasty.Silver.Internal import Test.Tasty.Options +import Test.Tasty.Silver.Filter import Data.Monoid import System.IO.Temp @@ -14,11 +15,10 @@ import Data.List (sort) import Control.Concurrent.MVar import Control.Monad.IO.Class -import Control.Concurrent touch f = writeFile f "" -main = defaultMain $ testGroup "tests" [testFindByExt, testWithResource] +main = defaultMain $ testGroup "tests" [testFindByExt, testWithResource, testCheckRF] @@ -50,7 +50,7 @@ free v = swapMVar v False >> return () test = \v -> goldenTest1 "check res" (return Nothing) (liftIO $ testAction v) (\_ _ -> Equal) (\_ -> ShowText mempty) upd upd x = assertBool "Incorrect result" x >> return () - testAction = \v -> v >>= readMVar >>= assertBool "Resource not initialized." >> threadDelay 10000000 >> return True + testAction = \v -> v >>= readMVar >>= assertBool "Resource not initialized." >> return True tree = withResource acq free test let r = tryIngredients [consoleTestReporter] (singleOption $ AcceptTests True) tree @@ -59,3 +59,11 @@ success <- r' assertBool "Test should succeed." success Nothing -> assertFailure "Test broken" + +testCheckRF :: TestTree +testCheckRF = testGroup "Filter.checkRF" + [ testCase "empty1" $ checkRF True [] "/" @?= True + , testCase "empty1" $ checkRF False [] "/" @?= False + , testCase "empty2" $ checkRF True [] "/sdfg" @?= True + , testCase "empty2" $ checkRF False [] "/sdfg" @?= False + ]