Allow --pattern|-p option to repeat

.github/workflows/ci.yaml

@@ -69,6 +69,7 @@ jobs:
         core-tests/exit-status-tests.sh
         # Prevent Git for Windows from replacing slashes with backslashes in patterns
         MSYS_NO_PATHCONV=1 core-tests/failing-pattern-test.sh
+        core-tests/multiple-pattern-test.sh
 
     - name: Test resource-release-test.sh
       if: runner.os != 'Windows'

core-tests/core-tests.cabal

@@ -50,3 +50,9 @@ executable failing-pattern-test
   build-depends:       base <= 5, tasty, tasty-hunit, random >= 1.2, mtl
   default-extensions:  ScopedTypeVariables
   ghc-options:         -Wall -fno-warn-type-defaults
+
+executable multiple-pattern-test
+  import:              commons
+  main-is:             multiple-pattern-test.hs
+  build-depends:       base < 5, tasty, tasty-hunit
+  ghc-options:         -Wall -fno-warn-type-defaults

core-tests/multiple-pattern-test.hs

@@ -0,0 +1,14 @@
+import Test.Tasty
+import Test.Tasty.HUnit
+
+main :: IO ()
+main = defaultMain $ testGroup "all"
+  [ testGroup "red"
+    [ testCase "square" $ pure ()
+    , testCase "circle" $ pure ()
+    ]
+  , testGroup "green"
+    [ testCase "square" $ pure ()
+    , testCase "circle" $ pure ()
+    ]
+  ]

core-tests/multiple-pattern-test.sh

@@ -0,0 +1,28 @@
+#!/bin/sh
+
+set -eux
+
+if ! command -v multiple-pattern-test
+then
+  echo "multiple-pattern-test executable is not in PATH, aborting"
+  exit 1
+fi
+
+[ "$(multiple-pattern-test -l | wc -l)" -eq 4 ]
+[ "$(multiple-pattern-test -l -p red | wc -l)" -eq 2 ]
+[ "$(multiple-pattern-test -l -p circle | wc -l)" -eq 2 ]
+[ "$(multiple-pattern-test -l -p red -p circle | wc -l)" -eq 1 ]
+[ "$(multiple-pattern-test -l -p red -p circle -p green | wc -l)" -eq 0 ]
+
+# Edge case: the empty pattern matches everything
+[ "$(multiple-pattern-test -l -p '' | wc -l)" -eq 4 ]
+[ "$(multiple-pattern-test -l -p '' -p '' | wc -l)" -eq 4 ]
+[ "$(multiple-pattern-test -l -p '' -p red | wc -l)" -eq 2 ]
+[ "$(multiple-pattern-test -l -p red -p '' | wc -l)" -eq 2 ]
+[ "$(multiple-pattern-test -l -p '' -p red -p '' | wc -l)" -eq 2 ]
+[ "$(multiple-pattern-test -l -p red -p '' -p circle | wc -l)" -eq 1 ]
+
+# Environment variable is entirely overridden by any command line options
+[ "$(TASTY_PATTERN=red.circle multiple-pattern-test -l | wc -l)" -eq 1 ]
+[ "$(TASTY_PATTERN=red.circle multiple-pattern-test -l -p square | wc -l)" -eq 2 ]
+[ "$(TASTY_PATTERN=red.circle multiple-pattern-test -l -p square -p green | wc -l)" -eq 1 ]

core/CHANGELOG.md

@@ -14,6 +14,7 @@ _YYYY-MM-DD_
 * `PrintTest` constructor now has an extra field used to report progress.
   Supply `const (pure ())` as this extra field value if you want to skip progress reporting.
 * Progress reporting is no longer ignored.
+* The `-p`/`--pattern` option can be specified multiple times; only tests that match all patterns are run.
 
 Version 1.4.3
 ---------------

core/Test/Tasty/Patterns.hs

@@ -1,6 +1,6 @@
 -- | Test patterns
 
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, TypeApplications #-}
 
 module Test.Tasty.Patterns
   ( TestPattern(..)
@@ -18,6 +18,9 @@ import Test.Tasty.Patterns.Parser
 import Test.Tasty.Patterns.Eval
 
 import Data.Char
+import Data.Coerce (coerce)
+import Data.List.NonEmpty (nonEmpty)
+import Data.Maybe (catMaybes)
 import Data.Typeable
 import Options.Applicative hiding (Success)
 #if !MIN_VERSION_base(4,11,0)
@@ -39,12 +42,16 @@ newtype TestPattern =
 noPattern :: TestPattern
 noPattern = TestPattern Nothing
 
+-- | Since tasty-1.5, this option can be specified multiple times on the
+-- command line. Only the tests matching all given patterns will be selected.
 instance IsOption TestPattern where
   defaultValue = noPattern
   parseValue = parseTestPattern
   optionName = return "pattern"
   optionHelp = return "Select only tests which satisfy a pattern or awk expression"
-  optionCLParser = mkOptionCLParser (short 'p' <> metavar "PATTERN")
+  optionCLParser =
+    fmap (TestPattern . fmap (foldr1 And) . nonEmpty . catMaybes . coerce @[TestPattern]) . some $
+      mkOptionCLParser (short 'p' <> metavar "PATTERN")
 
 -- | @since 1.2
 parseExpr :: String -> Maybe Expr