allow multiple (and-ed) filters

This commit is contained in:
rhiannon morris 2023-09-17 16:59:21 +02:00
parent 28f0546903
commit 46d94df444
2 changed files with 25 additions and 18 deletions

31
TAP.idr
View file

@ -356,26 +356,33 @@ parameters (skipNotes : Bool)
all id <$> traverse (\t => run' (assert_smaller tests t)) tests'
export
filterMatchStr : List String -> String -> List String
filterMatchStr pats label = filter (\p => not $ p `isInfixOf` label) pats
mutual
||| filter tests by whether a string occurs in their name or in the name of
||| any of their parent groups
export
filterMatch : Maybe String -> List Test -> List Test
filterMatch Nothing tests = tests
filterMatch (Just pat) tests =
mapMaybe (\t => filterMatch1 pat (assert_smaller tests t)) tests
filterMatch : List String -> List Test -> List Test
filterMatch [] tests = tests
filterMatch pats tests =
mapMaybe (\t => filterMatch1 pats $ assert_smaller tests t) tests
||| filter subtests by whether a string occurs in their name or in the name of
||| any of their parent groups. return `Nothing` if nothing remains
export
filterMatch1 : String -> Test -> Maybe Test
filterMatch1 pat test@(One base) =
guard (pat `isInfixOf` base.label) $> test
filterMatch1 pat whole@(Group label tests) =
if pat `isInfixOf` label then Just whole else
let res = filterMatch (Just pat) tests in
guard (any isRealTest res) $> Group label res
filterMatch1 pat note@(Note _) = Just note
filterMatch1 : List String -> Test -> Maybe Test
filterMatch1 pats test@(One base) = do
guard $ null $ filterMatchStr pats base.label
pure test
filterMatch1 pats whole@(Group label tests) =
case filterMatchStr pats label of
[] => Just whole
rest => do let res = filterMatch rest tests
guard $ any isRealTest res
pure $ Group label res
filterMatch1 _ note@(Note _) = Just note
||| run some tests, and return `ExitSuccess` if they were all ok, and

View file

@ -36,10 +36,10 @@ record Options where
||| which TAP version to output
version : TAPVersion
||| `-F`, `--filter`:
||| search for a substring in test or group names.
||| if it is present in a group name then all subtests are run
||| regardless of their own names
pattern : Maybe String
||| search for substrings in test or group names.
||| if there are several, then each must be present somewhere in the
||| test's name or in the name of one of its parent groups
pattern : List String
||| `-c`, `--color`, `--colour`:
||| colour code test results and a few other things.
||| this is not TAP compliant so it is off by default.
@ -54,7 +54,7 @@ export
defaultOpts : Options
defaultOpts = Opts {
version = V13,
pattern = Nothing,
pattern = [],
color = False,
skipComments = False
}
@ -86,7 +86,7 @@ setTapVer ver opts =
private
setFilter : String -> Mod
setFilter str opts = pure $ {pattern := Just str} opts
setFilter str opts = pure $ {pattern $= (str ::)} opts
parameters (header : String)
mutual