{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards, DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
-- | Regex filtering for test trees.
module Test.Tasty.Silver.Filter
  ( filterWithRegex
  , checkRF
  , RegexFilter (..)
  , IncludeFilters (..)
  , ExcludeFilters (..)
  , TestPath
  )
  where

import Prelude hiding (fail)
import Test.Tasty hiding (defaultMain)
import Test.Tasty.Runners
import Test.Tasty.Options
import Data.Tagged
import Data.Typeable
import Data.Maybe
import Data.Monoid
import qualified Data.List as L
import Options.Applicative
import qualified Text.Regex.TDFA.String as RS
import qualified Text.Regex.TDFA as R

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 :: String -> Maybe ExcludeFilters
parseValue = ([RegexFilter] -> ExcludeFilters)
-> Maybe [RegexFilter] -> Maybe ExcludeFilters
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [RegexFilter] -> ExcludeFilters
ExcludeFilters (Maybe [RegexFilter] -> Maybe ExcludeFilters)
-> (String -> Maybe [RegexFilter])
-> String
-> Maybe ExcludeFilters
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> RegexFilter) -> String -> Maybe [RegexFilter]
parseValue1 String -> RegexFilter
RFExclude
  optionName :: Tagged ExcludeFilters String
optionName = String -> Tagged ExcludeFilters String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"regex-exclude"
  optionHelp :: Tagged ExcludeFilters String
optionHelp = String -> Tagged ExcludeFilters String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"Exclude tests matching a regex (experimental)."
  optionCLParser :: Parser ExcludeFilters
optionCLParser = (String -> RegexFilter)
-> ([RegexFilter] -> ExcludeFilters) -> Parser ExcludeFilters
forall v.
IsOption v =>
(String -> RegexFilter) -> ([RegexFilter] -> v) -> Parser v
parseFilter String -> RegexFilter
RFExclude [RegexFilter] -> ExcludeFilters
ExcludeFilters

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

compileRegex :: String -> Maybe RS.Regex
compileRegex :: String -> Maybe Regex
compileRegex = (String -> Maybe Regex)
-> (Regex -> Maybe Regex) -> Either String Regex -> Maybe Regex
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Regex -> String -> 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 String Regex -> Maybe Regex)
-> (String -> Either String Regex) -> String -> Maybe Regex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompOption -> ExecOption -> String -> Either String 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 :: (String -> RegexFilter) -> ([RegexFilter] -> v) -> Parser v
parseFilter String -> 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 (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 ( String -> Mod OptionFields RegexFilter
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
name Mod OptionFields RegexFilter
-> Mod OptionFields RegexFilter -> Mod OptionFields RegexFilter
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields RegexFilter
forall (f :: * -> *) a. String -> Mod f a
help String
helpString))
  where
    name :: String
name = Tagged v String -> String
forall k (s :: k) b. Tagged s b -> b
untag (Tagged v String
forall v. IsOption v => Tagged v String
optionName :: Tagged v String)
    helpString :: String
helpString = Tagged v String -> String
forall k (s :: k) b. Tagged s b -> b
untag (Tagged v String
forall v. IsOption v => Tagged v String
optionHelp :: Tagged v String)
    parse :: ReadM RegexFilter
parse = (ReadM String
forall s. IsString s => ReadM s
str ReadM String -> (String -> ReadM RegexFilter) -> ReadM RegexFilter
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (String -> ReadM RegexFilter)
-> (Regex -> ReadM RegexFilter)
-> Either String Regex
-> ReadM RegexFilter
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
err -> String -> ReadM RegexFilter
forall a. String -> ReadM a
readerError (String -> ReadM RegexFilter) -> String -> ReadM RegexFilter
forall a b. (a -> b) -> a -> b
$ String
"Could not parse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err) (\Regex
_ -> String -> RegexFilter
mkRF (String -> RegexFilter) -> ReadM String -> ReadM RegexFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM String
forall s. IsString s => ReadM s
str)
        (Either String Regex -> ReadM RegexFilter)
-> (String -> Either String Regex) -> String -> ReadM RegexFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CompOption -> ExecOption -> String -> Either String 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 :: (String -> RegexFilter) -> String -> Maybe [RegexFilter]
parseValue1 String -> RegexFilter
f String
x = (Regex -> [RegexFilter]) -> Maybe Regex -> Maybe [RegexFilter]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([RegexFilter] -> Regex -> [RegexFilter]
forall a b. a -> b -> a
const ([RegexFilter] -> Regex -> [RegexFilter])
-> [RegexFilter] -> Regex -> [RegexFilter]
forall a b. (a -> b) -> a -> b
$ [String -> RegexFilter
f String
x]) (Maybe Regex -> Maybe [RegexFilter])
-> Maybe Regex -> Maybe [RegexFilter]
forall a b. (a -> b) -> a -> b
$ String -> Maybe Regex
compileRegex String
x

filterWithRegex :: OptionSet -> TestTree -> TestTree
filterWithRegex :: OptionSet -> TestTree -> TestTree
filterWithRegex OptionSet
opts = (String -> Bool) -> TestTree -> TestTree
filterWithPred (Bool -> [RegexFilter] -> String -> Bool
checkRF Bool
True ([RegexFilter] -> String -> Bool)
-> [RegexFilter] -> String -> Bool
forall a b. (a -> b) -> a -> b
$ [RegexFilter]
excRgxs [RegexFilter] -> [RegexFilter] -> [RegexFilter]
forall a. [a] -> [a] -> [a]
++ [RegexFilter]
incRgxs)
  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


-- | 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 1. condition if no RFInclude is given.
    -> [RegexFilter]
    -> TestPath -> Bool
checkRF :: Bool -> [RegexFilter] -> String -> Bool
checkRF Bool
ignNoInc [RegexFilter]
rf String
tp =
  (([RegexFilter] -> 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 String
_) = Bool
True
        isInclude (RFExclude String
_) = 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 String
rgx) = Regex -> String -> 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
$ String -> Maybe Regex
compileRegex String
rgx) String
tp
        regexMatches (RFExclude String
rgx) = Regex -> String -> 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
$ String -> Maybe Regex
compileRegex String
rgx) String
tp


filterWithPred :: (TestPath -> Bool) -> TestTree -> TestTree
filterWithPred :: (String -> Bool) -> TestTree -> TestTree
filterWithPred String -> Bool
prd TestTree
tree = TestTree -> Maybe TestTree -> TestTree
forall a. a -> Maybe a -> a
fromMaybe TestTree
emptyTest (String -> TestTree -> Maybe TestTree
filter' String
"/" TestTree
tree)
  where String
x <//> :: String -> String -> String
<//> String
y = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y

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

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