diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------------- diff --git a/Test/Tasty/Silver/Filter.hs b/Test/Tasty/Silver/Filter.hs new file mode 100644 --- /dev/null +++ b/Test/Tasty/Silver/Filter.hs @@ -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 "" [] + 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 @@ -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 diff --git a/tasty-silver.cabal b/tasty-silver.cabal --- a/tasty-silver.cabal +++ b/tasty-silver.cabal @@ -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 diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -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