tasty-silver 3.1.5 → 3.1.6

raw patch · 5 files changed

+118/−67 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• Test/Tasty/Silver/Filter.hs +105/−0
• Test/Tasty/Silver/Interactive.hs +3/−65
• tasty-silver.cabal +2/−1
• tests/test.hs +2/−1

@@ -1,6 +1,12 @@ Changes ======= +Version 3.1.6+-------------++* Expose regex filter modules.+* Fix issue with regex filters when used together with withResource nodes.+ Version 3.1.5 ------------- 

@@ -0,0 +1,105 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+-- | Regex filtering for test trees.+module Test.Tasty.Silver.Filter+  ( filterWithRegex+  , filterWithRegex1+  , RegexFilter (..)+  , IncludeFilters (..)+  , ExcludeFilters (..)+  )+  where++import Prelude hiding (fail)+import Test.Tasty hiding (defaultMain)+import Test.Tasty.Runners+import Test.Tasty.Options+import Data.Tagged+import Data.Typeable+import Data.Maybe+import Data.Monoid+#if __GLASGOW_HASKELL__ < 708+import Data.Foldable (foldMap)+#endif+#if __GLASGOW_HASKELL__ < 708+import Data.Proxy+#endif+import Options.Applicative+import qualified Text.Regex.TDFA.String as RS+import qualified Text.Regex.TDFA as R++-- 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+  = RFInclude String -- include tests that match+  | RFExclude String -- exclude tests that match+  deriving (Typeable)++newtype ExcludeFilters = ExcludeFilters [RegexFilter]+  deriving (Typeable)++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+  optionName = return "regex-exclude"+  optionHelp = return "Exclude tests matching a regex (experimental)."+  optionCLParser = parseFilter RFExclude ExcludeFilters++instance IsOption IncludeFilters where+  defaultValue = IncludeFilters []+  parseValue = fmap IncludeFilters . parseValue1 RFInclude+  optionName = return "regex-include"+  optionHelp = return "Include only tests matching a regex (experimental)."+  optionCLParser = parseFilter RFInclude IncludeFilters+++filterWithRegex :: OptionSet -> TestTree -> TestTree+filterWithRegex opts tree = foldl (filterWithRegex1 opts) tree (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++        prd = case rf of+            RFInclude rgx -> R.matchTest (fromJust $ compileRegex rgx)+            RFExclude rgx -> not . R.matchTest (fromJust $ compileRegex rgx)++        filter' :: String -> 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 (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+        -- if later on we see that the child subtree was excluded.+        filter' pth (WithResource r t) = Just $ WithResource r (\x -> fromMaybe emptyTest (filter' pth (t x)))+        filter' pth (AskOptions t) = Just $ AskOptions (\o -> fromMaybe emptyTest (filter' pth (t o)))++        emptyTest = testGroup "" []+

@@ -25,6 +25,7 @@ import Test.Tasty hiding (defaultMain) import Test.Tasty.Runners import Test.Tasty.Options+import Test.Tasty.Silver.Filter import Test.Tasty.Silver.Internal import Test.Tasty.Silver.Interactive.Run import Data.Typeable@@ -60,8 +61,8 @@ import qualified Data.Map as M import System.Console.ANSI import qualified System.Process.Text as PTL-import qualified Text.Regex.TDFA.String as RS-import qualified Text.Regex.TDFA as R++ -- | Like @defaultMain@ from the main tasty package, but also includes the -- golden test management capabilities. defaultMain :: TestTree -> IO ()@@ -76,48 +77,7 @@   optionHelp = return "Run tests in interactive mode."   optionCLParser = flagCLParser (Just 'i') (Interactive True) --- 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-  = RFInclude String -- include tests that match-  | RFExclude String -- exclude tests that match-  deriving (Typeable) -newtype ExcludeFilters = ExcludeFilters [RegexFilter]-  deriving (Typeable)--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-  optionName = return "regex-exclude"-  optionHelp = return "Exclude tests matching a regex (experimental)."-  optionCLParser = parseFilter RFExclude ExcludeFilters--instance IsOption IncludeFilters where-  defaultValue = IncludeFilters []-  parseValue = fmap IncludeFilters . parseValue1 RFInclude-  optionName = return "regex-include"-  optionHelp = return "Include only tests matching a regex (experimental)."-  optionCLParser = parseFilter RFInclude IncludeFilters- data ResultStatus = RPass | RFail | RMismatch GoldenResultI  type GoldenStatus = GoldenResultI@@ -135,28 +95,6 @@     ] $   \opts tree ->       Just $ runTestsInteractive opts (filterWithRegex opts tree)--filterWithRegex :: OptionSet -> TestTree -> TestTree-filterWithRegex opts tree = foldl (filterWithRegex1 opts) tree (excRgxs ++ incRgxs)-  where ExcludeFilters excRgxs = lookupOption opts-        IncludeFilters incRgxs = lookupOption opts---filterWithRegex1 :: OptionSet -> TestTree -> RegexFilter -> TestTree-filterWithRegex1 opts tree rf = case rf of-    RFInclude rgx -> filter' (R.matchTest (fromJust $ compileRegex rgx))-    RFExclude rgx -> filter' (not . R.matchTest (fromJust $ compileRegex rgx))-  where x <//> y = x ++ "/" ++ y-        filter' :: (String -> Bool) -> TestTree-        filter' pred' =-            let alg :: TreeFold [String -> Maybe TestTree]-                alg = trivialFold-                    { foldSingle = \_ nm t -> [\pth -> if pred' (pth <//> nm) then Just (SingleTest nm t) else Nothing]-                    , foldGroup  = \nm chlds -> [\pth -> Just $ TestGroup nm (catMaybes $ map (\x -> x (pth <//> nm)) chlds)]-                    }-                [root] = foldTestTree alg opts tree-             in maybe (testGroup "" []) (id) (root "")-  runSingleTest ::  IsTest t => GoldenStatusMap -> TestName -> OptionSet -> t -> (Progress -> IO ()) -> IO Result runSingleTest gs n opts t cb = do

@@ -1,5 +1,5 @@ name:                tasty-silver-version:             3.1.5+version:             3.1.6 synopsis:            Golden tests support for tasty. Fork of tasty-golden. description:   This package provides support for «golden testing».@@ -29,6 +29,7 @@     Haskell2010   exposed-modules:     Test.Tasty.Silver                        Test.Tasty.Silver.Advanced+                       Test.Tasty.Silver.Filter                        Test.Tasty.Silver.Interactive                        Test.Tasty.Silver.Interactive.Run                        Test.Tasty.Silver.Internal

@@ -14,6 +14,7 @@ import Data.List (sort) import Control.Concurrent.MVar import Control.Monad.IO.Class+import Control.Concurrent  touch f = writeFile f "" @@ -49,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." >> return True+        testAction = \v -> v >>= readMVar >>= assertBool "Resource not initialized." >> threadDelay 10000000 >> return True         tree = withResource acq free test      let r = tryIngredients [consoleTestReporter] (singleOption $ AcceptTests True) tree