{-# 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RegexFilter] -> ExcludeFilters
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 = forall (m :: * -> *) a. Monad m => a -> m a
return TestPath
"regex-exclude"
  optionHelp :: Tagged ExcludeFilters TestPath
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return TestPath
"Exclude tests matching a regex (experimental)."
  optionCLParser :: Parser ExcludeFilters
optionCLParser = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RegexFilter] -> IncludeFilters
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 = forall (m :: * -> *) a. Monad m => a -> m a
return TestPath
"regex-include"
  optionHelp :: Tagged IncludeFilters TestPath
optionHelp = forall (m :: * -> *) a. Monad m => a -> m a
return TestPath
"Include only tests matching a regex (experimental)."
  optionCLParser :: Parser IncludeFilters
optionCLParser = 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 = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompOption -> ExecOption -> TestPath -> Either TestPath Regex
RS.compile forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
R.defaultCompOpt 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ( forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM RegexFilter
parse ( forall (f :: * -> *) a. HasName f => TestPath -> Mod f a
long TestPath
name forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. TestPath -> Mod f a
help TestPath
helpString))
  where
    name :: TestPath
name = forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v TestPath
optionName :: Tagged v String)
    helpString :: TestPath
helpString = forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v TestPath
optionHelp :: Tagged v String)
    parse :: ReadM RegexFilter
parse = (forall s. IsString s => ReadM s
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\TestPath
err -> forall a. TestPath -> ReadM a
readerError forall a b. (a -> b) -> a -> b
$ TestPath
"Could not parse " forall a. [a] -> [a] -> [a]
++ TestPath
name forall a. [a] -> [a] -> [a]
++ TestPath
": " forall a. [a] -> [a] -> [a]
++ TestPath
err) (\Regex
_ -> TestPath -> RegexFilter
mkRF forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IsString s => ReadM s
str)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption -> ExecOption -> TestPath -> Either TestPath Regex
RS.compile forall regex compOpt execOpt.
RegexOptions regex compOpt execOpt =>
compOpt
R.defaultCompOpt 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const [TestPath -> RegexFilter
f TestPath
x]) 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RegexFilter]
filters
    then forall a. a -> a
id
    else (TestPath -> Bool) -> TestTree -> TestTree
filterWithPred (Bool -> [RegexFilter] -> TestPath -> Bool
checkRF Bool
True [RegexFilter]
filters)
  where
    ExcludeFilters [RegexFilter]
excRgxs = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    IncludeFilters [RegexFilter]
incRgxs = forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    filters :: [RegexFilter]
filters = [RegexFilter]
excRgxs 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 =
  ((forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RegexFilter]
incRgxs Bool -> Bool -> Bool
&& Bool
ignNoInc) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RegexFilter -> Bool
regexMatches [RegexFilter]
incRgxs)
    Bool -> Bool -> Bool
&& (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any RegexFilter -> Bool
regexMatches [RegexFilter]
excRgxs)
  where ([RegexFilter]
incRgxs, [RegexFilter]
excRgxs) = 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) = forall regex source.
RegexLike regex source =>
regex -> source -> Bool
R.matchTest (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ TestPath -> Maybe Regex
compileRegex TestPath
rgx) TestPath
tp
        regexMatches (RFExclude TestPath
rgx) = forall regex source.
RegexLike regex source =>
regex -> source -> Bool
R.matchTest (forall a. HasCallStack => Maybe a -> a
fromJust 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 = forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest 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 forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall t. IsTest t => TestPath -> t -> TestTree
SingleTest TestPath
n t
t else forall a. Maybe a
Nothing
      TestGroup TestPath
n [TestTree]
ts      -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TestPath -> [TestTree] -> TestTree
TestGroup TestPath
n forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (TestPath -> TestTree -> Maybe TestTree
filter' 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 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    -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. ResourceSpec a -> (IO a -> TestTree) -> TestTree
WithResource ResourceSpec a
r forall a b. (a -> b) -> a -> b
$ \ IO a
x -> forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest forall a b. (a -> b) -> a -> b
$ TestPath -> TestTree -> Maybe TestTree
filter' TestPath
path forall a b. (a -> b) -> a -> b
$ IO a -> TestTree
t IO a
x
      AskOptions OptionSet -> TestTree
t        -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (OptionSet -> TestTree) -> TestTree
AskOptions     forall a b. (a -> b) -> a -> b
$ \ OptionSet
o -> forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest forall a b. (a -> b) -> a -> b
$ TestPath -> TestTree -> Maybe TestTree
filter' TestPath
path forall a b. (a -> b) -> a -> b
$ OptionSet -> TestTree
t OptionSet
o

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

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