{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Regex filtering for test trees.
module Test.Tasty.Silver.Filter
  ( filterWithRegex
  , checkRF
  , RegexFilter (..)
  , IncludeFilters (..)
  , ExcludeFilters (..)
  , TestPath
  )
  where

import Prelude hiding (fail)

import Data.Maybe
#if !(MIN_VERSION_base(4,11,0))
import Data.Semigroup ( (<>) )
#endif
import Data.Tagged
import Data.Typeable
import qualified Data.List as L

import Options.Applicative

import qualified Text.Regex.TDFA.String as RS
import qualified Text.Regex.TDFA as R

import Test.Tasty hiding (defaultMain)
import Test.Tasty.Options
import Test.Tasty.Runners

-- | Path into the 'TestTree'.  Separator is the slash character(@'/'@).
type TestPath = String

-- 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)

-- | Tests to completely exclude, treating them like they do not exist.
newtype ExcludeFilters = ExcludeFilters [RegexFilter]
  deriving (Typeable)

-- | Tests to completely include, treating all other tests like they do not exist.
newtype IncludeFilters = IncludeFilters [RegexFilter]
  deriving (Typeable)

instance IsOption ExcludeFilters where
  defaultValue :: ExcludeFilters
defaultValue = [RegexFilter] -> ExcludeFilters
ExcludeFilters []
  parseValue :: TestPath -> Maybe ExcludeFilters
parseValue = ([RegexFilter] -> ExcludeFilters)
-> Maybe [RegexFilter] -> Maybe ExcludeFilters
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RegexFilter] -> ExcludeFilters
ExcludeFilters (Maybe [RegexFilter] -> Maybe ExcludeFilters)
-> (TestPath -> Maybe [RegexFilter])
-> TestPath
-> Maybe ExcludeFilters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestPath -> RegexFilter) -> TestPath -> Maybe [RegexFilter]
parseValue1 TestPath -> RegexFilter
RFExclude
  optionName :: Tagged ExcludeFilters TestPath
optionName = TestPath -> Tagged ExcludeFilters TestPath
forall a. a -> Tagged ExcludeFilters a
forall (m :: * -> *) a. Monad m => a -> m a
return TestPath
"regex-exclude"
  optionHelp :: Tagged ExcludeFilters TestPath
optionHelp = TestPath -> Tagged ExcludeFilters TestPath
forall a. a -> Tagged ExcludeFilters a
forall (m :: * -> *) a. Monad m => a -> m a
return TestPath
"Exclude tests matching a regex (experimental)."
  optionCLParser :: Parser ExcludeFilters
optionCLParser = (TestPath -> RegexFilter)
-> ([RegexFilter] -> ExcludeFilters) -> Parser ExcludeFilters
forall v.
IsOption v =>
(TestPath -> RegexFilter) -> ([RegexFilter] -> v) -> Parser v
parseFilter TestPath -> RegexFilter
RFExclude [RegexFilter] -> ExcludeFilters
ExcludeFilters

instance IsOption IncludeFilters where
  defaultValue :: IncludeFilters
defaultValue = [RegexFilter] -> IncludeFilters
IncludeFilters []
  parseValue :: TestPath -> Maybe IncludeFilters
parseValue = ([RegexFilter] -> IncludeFilters)
-> Maybe [RegexFilter] -> Maybe IncludeFilters
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RegexFilter] -> IncludeFilters
IncludeFilters (Maybe [RegexFilter] -> Maybe IncludeFilters)
-> (TestPath -> Maybe [RegexFilter])
-> TestPath
-> Maybe IncludeFilters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TestPath -> RegexFilter) -> TestPath -> Maybe [RegexFilter]
parseValue1 TestPath -> RegexFilter
RFInclude
  optionName :: Tagged IncludeFilters TestPath
optionName = TestPath -> Tagged IncludeFilters TestPath
forall a. a -> Tagged IncludeFilters a
forall (m :: * -> *) a. Monad m => a -> m a
return TestPath
"regex-include"
  optionHelp :: Tagged IncludeFilters TestPath
optionHelp = TestPath -> Tagged IncludeFilters TestPath
forall a. a -> Tagged IncludeFilters a
forall (m :: * -> *) a. Monad m => a -> m a
return TestPath
"Include only tests matching a regex (experimental)."
  optionCLParser :: Parser IncludeFilters
optionCLParser = (TestPath -> RegexFilter)
-> ([RegexFilter] -> IncludeFilters) -> Parser IncludeFilters
forall v.
IsOption v =>
(TestPath -> RegexFilter) -> ([RegexFilter] -> v) -> Parser v
parseFilter TestPath -> RegexFilter
RFInclude [RegexFilter] -> IncludeFilters
IncludeFilters

compileRegex :: String -> Maybe RS.Regex
compileRegex :: TestPath -> Maybe Regex
compileRegex = (TestPath -> Maybe Regex)
-> (Regex -> Maybe Regex) -> Either TestPath Regex -> Maybe Regex
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Regex -> TestPath -> Maybe Regex
forall a b. a -> b -> a
const Maybe Regex
forall a. Maybe a
Nothing) Regex -> Maybe Regex
forall a. a -> Maybe a
Just (Either TestPath Regex -> Maybe Regex)
-> (TestPath -> Either TestPath Regex) -> TestPath -> Maybe Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompOption -> ExecOption -> TestPath -> Either TestPath Regex
RS.compile CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
R.defaultCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
R.defaultExecOpt

parseFilter :: forall v . IsOption v => (String -> RegexFilter) -> ([RegexFilter] -> v) -> Parser v
parseFilter :: forall v.
IsOption v =>
(TestPath -> RegexFilter) -> ([RegexFilter] -> v) -> Parser v
parseFilter TestPath -> RegexFilter
mkRF [RegexFilter] -> v
mkV = [RegexFilter] -> v
mkV ([RegexFilter] -> v) -> Parser [RegexFilter] -> Parser v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser RegexFilter -> Parser [RegexFilter]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ( ReadM RegexFilter
-> Mod OptionFields RegexFilter -> Parser RegexFilter
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM RegexFilter
parse ( TestPath -> Mod OptionFields RegexFilter
forall (f :: * -> *) a. HasName f => TestPath -> Mod f a
long TestPath
name Mod OptionFields RegexFilter
-> Mod OptionFields RegexFilter -> Mod OptionFields RegexFilter
forall a. Semigroup a => a -> a -> a
<> TestPath -> Mod OptionFields RegexFilter
forall (f :: * -> *) a. TestPath -> Mod f a
help TestPath
helpString))
  where
    name :: TestPath
name = Tagged v TestPath -> TestPath
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged v TestPath
forall v. IsOption v => Tagged v TestPath
optionName :: Tagged v String)
    helpString :: TestPath
helpString = Tagged v TestPath -> TestPath
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged v TestPath
forall v. IsOption v => Tagged v TestPath
optionHelp :: Tagged v String)
    parse :: ReadM RegexFilter
parse = (ReadM TestPath
forall s. IsString s => ReadM s
str ReadM TestPath
-> (TestPath -> ReadM RegexFilter) -> ReadM RegexFilter
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (TestPath -> ReadM RegexFilter)
-> (Regex -> ReadM RegexFilter)
-> Either TestPath Regex
-> ReadM RegexFilter
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\TestPath
err -> TestPath -> ReadM RegexFilter
forall a. TestPath -> ReadM a
readerError (TestPath -> ReadM RegexFilter) -> TestPath -> ReadM RegexFilter
forall a b. (a -> b) -> a -> b
$ TestPath
"Could not parse " TestPath -> TestPath -> TestPath
forall a. [a] -> [a] -> [a]
++ TestPath
name TestPath -> TestPath -> TestPath
forall a. [a] -> [a] -> [a]
++ TestPath
": " TestPath -> TestPath -> TestPath
forall a. [a] -> [a] -> [a]
++ TestPath
err) (\Regex
_ -> TestPath -> RegexFilter
mkRF (TestPath -> RegexFilter) -> ReadM TestPath -> ReadM RegexFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM TestPath
forall s. IsString s => ReadM s
str)
        (Either TestPath Regex -> ReadM RegexFilter)
-> (TestPath -> Either TestPath Regex)
-> TestPath
-> ReadM RegexFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption -> ExecOption -> TestPath -> Either TestPath Regex
RS.compile CompOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
R.defaultCompOpt ExecOption
forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
execOpt
R.defaultExecOpt)

parseValue1 :: (String -> RegexFilter) -> String -> Maybe [RegexFilter]
parseValue1 :: (TestPath -> RegexFilter) -> TestPath -> Maybe [RegexFilter]
parseValue1 TestPath -> RegexFilter
f TestPath
x = (Regex -> [RegexFilter]) -> Maybe Regex -> Maybe [RegexFilter]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([RegexFilter] -> Regex -> [RegexFilter]
forall a b. a -> b -> a
const [TestPath -> RegexFilter
f TestPath
x]) (Maybe Regex -> Maybe [RegexFilter])
-> Maybe Regex -> Maybe [RegexFilter]
forall a b. (a -> b) -> a -> b
$ TestPath -> Maybe Regex
compileRegex TestPath
x

filterWithRegex :: OptionSet -> TestTree -> TestTree
filterWithRegex :: OptionSet -> TestTree -> TestTree
filterWithRegex OptionSet
opts =
  -- Andreas, 2023-10-20: Since @filterWithPred (const True)@ is not the identity
  -- when the test tree contains 'WithResource' etc.,
  -- we skip it if it does not actually filter out anything.
  if [RegexFilter] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RegexFilter]
filters
    then TestTree -> TestTree
forall a. a -> a
id
    else (TestPath -> Bool) -> TestTree -> TestTree
filterWithPred (Bool -> [RegexFilter] -> TestPath -> Bool
checkRF Bool
True [RegexFilter]
filters)
  where
    ExcludeFilters [RegexFilter]
excRgxs = OptionSet -> ExcludeFilters
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    IncludeFilters [RegexFilter]
incRgxs = OptionSet -> IncludeFilters
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    filters :: [RegexFilter]
filters = [RegexFilter]
excRgxs [RegexFilter] -> [RegexFilter] -> [RegexFilter]
forall a. [a] -> [a] -> [a]
++ [RegexFilter]
incRgxs

-- | Check if the given path should be kept using regex filters.
-- A Tree leaf is retained if the following conditions
-- are met:
-- 1. At least one RFInclude matches.
-- 2. No RFExclude filter matches.
checkRF :: Bool -- ^ If 'True', ignore first condition if no 'RFInclude' is given.
    -> [RegexFilter]
    -> TestPath
    -> Bool
checkRF :: Bool -> [RegexFilter] -> TestPath -> Bool
checkRF Bool
ignNoInc [RegexFilter]
rf TestPath
tp =
  (([RegexFilter] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RegexFilter]
incRgxs Bool -> Bool -> Bool
&& Bool
ignNoInc) Bool -> Bool -> Bool
|| (RegexFilter -> Bool) -> [RegexFilter] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RegexFilter -> Bool
regexMatches [RegexFilter]
incRgxs)
    Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (RegexFilter -> Bool) -> [RegexFilter] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RegexFilter -> Bool
regexMatches [RegexFilter]
excRgxs)
  where ([RegexFilter]
incRgxs, [RegexFilter]
excRgxs) = (RegexFilter -> Bool)
-> [RegexFilter] -> ([RegexFilter], [RegexFilter])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (RegexFilter -> Bool
isInclude) [RegexFilter]
rf
        isInclude :: RegexFilter -> Bool
isInclude (RFInclude TestPath
_) = Bool
True
        isInclude (RFExclude TestPath
_) = Bool
False

        -- | Returns if the regex matches the test path.
        -- Does NOT differentiate between exclude and include
        -- filters!
        regexMatches :: RegexFilter -> Bool
        regexMatches :: RegexFilter -> Bool
regexMatches (RFInclude TestPath
rgx) = Regex -> TestPath -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
R.matchTest (Maybe Regex -> Regex
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Regex -> Regex) -> Maybe Regex -> Regex
forall a b. (a -> b) -> a -> b
$ TestPath -> Maybe Regex
compileRegex TestPath
rgx) TestPath
tp
        regexMatches (RFExclude TestPath
rgx) = Regex -> TestPath -> Bool
forall regex source.
RegexLike regex source =>
regex -> source -> Bool
R.matchTest (Maybe Regex -> Regex
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Regex -> Regex) -> Maybe Regex -> Regex
forall a b. (a -> b) -> a -> b
$ TestPath -> Maybe Regex
compileRegex TestPath
rgx) TestPath
tp


filterWithPred :: (TestPath -> Bool) -> TestTree -> TestTree
filterWithPred :: (TestPath -> Bool) -> TestTree -> TestTree
filterWithPred TestPath -> Bool
f TestTree
tree = TestTree -> Maybe TestTree -> TestTree
forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest (Maybe TestTree -> TestTree) -> Maybe TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestPath -> TestTree -> Maybe TestTree
filter' TestPath
"/" TestTree
tree
  where
    filter' :: TestPath -> TestTree -> Maybe TestTree
    filter' :: TestPath -> TestTree -> Maybe TestTree
filter' TestPath
path = \case
      SingleTest TestPath
n t
t      -> if TestPath -> Bool
f (TestPath
path TestPath -> TestPath -> TestPath
<//> TestPath
n) then TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just (TestTree -> Maybe TestTree) -> TestTree -> Maybe TestTree
forall a b. (a -> b) -> a -> b
$ TestPath -> t -> TestTree
forall t. IsTest t => TestPath -> t -> TestTree
SingleTest TestPath
n t
t else Maybe TestTree
forall a. Maybe a
Nothing
      TestGroup TestPath
n [TestTree]
ts      -> TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just (TestTree -> Maybe TestTree) -> TestTree -> Maybe TestTree
forall a b. (a -> b) -> a -> b
$ TestPath -> [TestTree] -> TestTree
TestGroup TestPath
n ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ (TestTree -> Maybe TestTree) -> [TestTree] -> [TestTree]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TestPath -> TestTree -> Maybe TestTree
filter' (TestPath -> TestTree -> Maybe TestTree)
-> TestPath -> TestTree -> Maybe TestTree
forall a b. (a -> b) -> a -> b
$ TestPath
path TestPath -> TestPath -> TestPath
<//> TestPath
n) [TestTree]
ts
      PlusTestOptions OptionSet -> OptionSet
o TestTree
t -> (OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions OptionSet -> OptionSet
o (TestTree -> TestTree) -> Maybe TestTree -> Maybe TestTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TestPath -> TestTree -> Maybe TestTree
filter' TestPath
path TestTree
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.
      WithResource ResourceSpec a
r IO a -> TestTree
t    -> TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just (TestTree -> Maybe TestTree) -> TestTree -> Maybe TestTree
forall a b. (a -> b) -> a -> b
$ ResourceSpec a -> (IO a -> TestTree) -> TestTree
forall a. ResourceSpec a -> (IO a -> TestTree) -> TestTree
WithResource ResourceSpec a
r ((IO a -> TestTree) -> TestTree) -> (IO a -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \ IO a
x -> TestTree -> Maybe TestTree -> TestTree
forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest (Maybe TestTree -> TestTree) -> Maybe TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestPath -> TestTree -> Maybe TestTree
filter' TestPath
path (TestTree -> Maybe TestTree) -> TestTree -> Maybe TestTree
forall a b. (a -> b) -> a -> b
$ IO a -> TestTree
t IO a
x
      AskOptions OptionSet -> TestTree
t        -> TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just (TestTree -> Maybe TestTree) -> TestTree -> Maybe TestTree
forall a b. (a -> b) -> a -> b
$ (OptionSet -> TestTree) -> TestTree
AskOptions     ((OptionSet -> TestTree) -> TestTree)
-> (OptionSet -> TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ \ OptionSet
o -> TestTree -> Maybe TestTree -> TestTree
forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest (Maybe TestTree -> TestTree) -> Maybe TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ TestPath -> TestTree -> Maybe TestTree
filter' TestPath
path (TestTree -> Maybe TestTree) -> TestTree -> Maybe TestTree
forall a b. (a -> b) -> a -> b
$ OptionSet -> TestTree
t OptionSet
o

    TestPath
x <//> :: TestPath -> TestPath -> TestPath
<//> TestPath
y = TestPath
x TestPath -> TestPath -> TestPath
forall a. [a] -> [a] -> [a]
++ TestPath
"/" TestPath -> TestPath -> TestPath
forall a. [a] -> [a] -> [a]
++ TestPath
y

    emptyTest :: TestTree
emptyTest = TestPath -> [TestTree] -> TestTree
testGroup TestPath
"" []