Skip to content

Commit

Permalink
Make cabal-testsuite filterable with --pattern
Browse files Browse the repository at this point in the history
This adds the `Tasty` `-p`/`--pattern` argument to the `cabal-testsuite`
tests, making it possible to filter `cabal-testsuite` tests just like
the other test suites:

    ./validate.sh -s build -s cli-suite -p HaddockKeepTmpsCustom
  • Loading branch information
9999years authored and Mikolaj committed Nov 10, 2024
1 parent 6bfdbfd commit 2d7b84d
Show file tree
Hide file tree
Showing 2 changed files with 41 additions and 5 deletions.
2 changes: 2 additions & 0 deletions cabal-testsuite/cabal-testsuite.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
44 changes: 39 additions & 5 deletions cabal-testsuite/main/cabal-tests.hs
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,19 @@ import Control.Exception
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
Expand Down Expand Up @@ -72,7 +84,8 @@ data MainArgs = MainArgs {
mainArgQuiet :: Bool,
mainArgDistDir :: Maybe FilePath,
mainArgCabalSpec :: Maybe CabalLibSpec,
mainCommonArgs :: CommonArgs
mainCommonArgs :: CommonArgs,
mainTastyArgs :: Tasty.OptionSet
}

data CabalLibSpec = BootCabalLib | InTreeCabalLib FilePath FilePath | SpecificCabalLib String FilePath
Expand Down Expand Up @@ -117,6 +130,17 @@ mainArgParser = MainArgs
<> 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]
Expand Down Expand Up @@ -184,6 +208,7 @@ main = do
-- 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
Expand Down Expand Up @@ -264,7 +289,7 @@ main = do
-- 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)
Expand Down Expand Up @@ -381,10 +406,19 @@ main = do
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 testPattern paths =
go [] [] paths
where
go ts ms [] = (ts, ms)
-- Filter a list, keeping only paths that match the @pattern@.
keepPatternMatches = filter (Tasty.testPatternMatches testPattern . 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
Expand Down

0 comments on commit 2d7b84d

Please sign in to comment.