packages feed

tasty-silver 3.1.6 → 3.1.7

raw patch · 7 files changed

+262/−149 lines, 7 filesdep ~base

Dependency ranges changed: base

Files

CHANGELOG.md view
@@ -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 -------------
Test/Tasty/Silver/Filter.hs view
@@ -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
Test/Tasty/Silver/Interactive.hs view
@@ -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 <enter> 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 <enter> 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
Test/Tasty/Silver/Interactive/Run.hs view
@@ -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
Test/Tasty/Silver/Internal.hs view
@@ -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"
tasty-silver.cabal view
@@ -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
tests/test.hs view
@@ -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+    ]