Add --tasty-arg to validate.sh

cabal-testsuite/cabal-testsuite.cabal

@@ -105,6 +105,8 @@ executable cabal-tests
     -- dependencies specific to exe:cabal-tests
     , clock                 ^>= 0.7.2 || ^>=0.8
     , directory
+    , tasty
+    , containers
 
   build-tool-depends: cabal-testsuite:setup
   default-extensions: TypeOperators

cabal-testsuite/main/cabal-tests.hs

@@ -23,7 +23,19 @@
 import Control.Monad
 import GHC.Conc (numCapabilities)
 import Data.List
+import Data.Proxy (Proxy(Proxy))
+import qualified Data.Sequence as Seq (fromList)
 import Text.Printf
+import qualified Test.Tasty.Options as Tasty
+  ( OptionSet
+  , OptionDescription (Option)
+  , lookupOption
+  )
+import qualified Test.Tasty.Runners as Tasty
+  ( optionParser
+  , TestPattern
+  , testPatternMatches
+  )
 import qualified System.Clock as Clock
 import System.IO
 import System.FilePath
@@ -72,7 +84,8 @@
         mainArgQuiet   :: Bool,
         mainArgDistDir :: Maybe FilePath,
         mainArgCabalSpec :: Maybe CabalLibSpec,
-        mainCommonArgs :: CommonArgs
+        mainCommonArgs :: CommonArgs,
+        mainTastyArgs :: Tasty.OptionSet
     }
 
 data CabalLibSpec = BootCabalLib | InTreeCabalLib FilePath FilePath | SpecificCabalLib String FilePath
@@ -117,6 +130,17 @@
        <> metavar "DIR"))
     <*> optional cabalLibSpecParser
     <*> commonArgParser
+    <*> tastyArgParser
+
+tastyArgParser :: Parser Tasty.OptionSet
+tastyArgParser =
+  let (warnings, parser) =
+        Tasty.optionParser
+          [ Tasty.Option (Proxy @Tasty.TestPattern)
+          ]
+   in if null warnings
+         then parser
+         else error $ unlines ("Failed to create parser for Tasty CLI options:" : warnings)
 
 -- Unpack and build a specific released version of Cabal and Cabal-syntax libraries
 buildCabalLibsProject :: String -> Verbosity -> Maybe FilePath -> FilePath -> IO [FilePath]
@@ -184,6 +208,7 @@
     -- Parse arguments.  N.B. 'helper' adds the option `--help`.
     args <- execParser $ info (mainArgParser <**> helper) mempty
     let verbosity = if mainArgVerbose args then verbose else normal
+        testPattern = Tasty.lookupOption @Tasty.TestPattern (mainTastyArgs args)
 
     pkg_dbs <-
       -- Not path to cabal-install so we're not going to run cabal-install tests so we
@@ -264,7 +289,7 @@
             -- NB: getDirectoryContentsRecursive is lazy IO, but it
             -- doesn't handle directories disappearing gracefully. Fix
             -- this!
-            (single_tests, multi_tests) <- evaluate (partitionTests test_scripts)
+            (single_tests, multi_tests) <- evaluate (partitionTests testPattern test_scripts)
             let all_tests = multi_tests ++ single_tests
                 margin = maximum (map length all_tests) + 2
             hPutStrLn stderr $ "tests to run: " ++ show (length all_tests)
@@ -381,10 +406,19 @@
 findTests :: IO [FilePath]
 findTests = getDirectoryContentsRecursive "."
 
-partitionTests :: [FilePath] -> ([FilePath], [FilePath])
-partitionTests = go [] []
+-- | Partition a list of paths into a tuple of test paths and multi-test paths.
+--
+-- Non-test paths and test paths that don't match the given `Tasty.TestPattern` are dropped.
+partitionTests :: Tasty.TestPattern -> [FilePath] -> ([FilePath], [FilePath])
+partitionTests pattern paths =
+  go [] [] paths
   where
-    go ts ms [] = (ts, ms)
+    -- Filter a list, keeping only paths that match the @pattern@.
+    keepPatternMatches = filter (Tasty.testPatternMatches pattern . toTastyPath)
+
+    toTastyPath path = Seq.fromList $ splitDirectories path
+
+    go ts ms [] = (keepPatternMatches ts, keepPatternMatches ms)
     go ts ms (f:fs) =
         -- NB: Keep this synchronized with isTestFile
         case takeExtensions f of

cabal-validate/src/Cli.hs

@@ -234,9 +234,11 @@
 
       tastyArgs' =
         "--hide-successes"
-          : case rawTastyPattern opts of
-            Just tastyPattern -> ["--pattern", tastyPattern]
-            Nothing -> []
+          : maybe
+            []
+            (\pattern -> ["--pattern", pattern])
+            (rawTastyPattern opts)
+          ++ rawTastyArgs opts
 
   when (rawListSteps opts) $ do
     -- TODO: This should probably list _all_ available steps, not just the selected ones!
@@ -279,6 +281,7 @@
   , rawCabal :: FilePath
   , rawExtraCompilers :: [FilePath]
   , rawTastyPattern :: Maybe String
+  , rawTastyArgs :: [String]
   , rawDoctest :: Bool
   , rawSteps :: [Step]
   , rawListSteps :: Bool
@@ -343,6 +346,12 @@
           <> help "Pattern to filter tests by"
           <> value Nothing
       )
+    <*> many
+      ( strOption
+          ( long "tasty-arg"
+              <> help "Extra arguments to pass to Tasty test suites"
+          )
+      )
     <*> boolOption
       False
       "doctest"