{-# 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 exlucde, 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 forall a b. (a -> b) -> a -> b
$ [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 = (TestPath -> Bool) -> TestTree -> TestTree
filterWithPred (Bool -> [RegexFilter] -> TestPath -> Bool
checkRF Bool
True forall a b. (a -> b) -> a -> b
$ [RegexFilter]
excRgxs forall a. [a] -> [a] -> [a]
++ [RegexFilter]
incRgxs)
  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


-- | 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
prd TestTree
tree = forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest (TestPath -> TestTree -> Maybe TestTree
filter' TestPath
"/" TestTree
tree)
  where TestPath
x <//> :: TestPath -> TestPath -> TestPath
<//> TestPath
y = TestPath
x forall a. [a] -> [a] -> [a]
++ TestPath
"/" forall a. [a] -> [a] -> [a]
++ TestPath
y

        filter' :: TestPath -> TestTree -> Maybe TestTree
        filter' :: TestPath -> TestTree -> Maybe TestTree
filter' TestPath
pth (SingleTest TestPath
n t
t) = if TestPath -> Bool
prd (TestPath
pth 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
        filter' TestPath
pth (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. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (TestPath -> TestTree -> Maybe TestTree
filter' forall a b. (a -> b) -> a -> b
$ TestPath
pth TestPath -> TestPath -> TestPath
<//> TestPath
n) [TestTree]
ts)
        filter' TestPath
pth (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
pth 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.
        filter' TestPath
pth (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 (\IO a
x -> forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest (TestPath -> TestTree -> Maybe TestTree
filter' TestPath
pth (IO a -> TestTree
t IO a
x)))
        filter' TestPath
pth (AskOptions OptionSet -> TestTree
t) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (OptionSet -> TestTree) -> TestTree
AskOptions (\OptionSet
o -> forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest (TestPath -> TestTree -> Maybe TestTree
filter' TestPath
pth (OptionSet -> TestTree
t OptionSet
o)))

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