module Test.Framework.Runners.TestPattern (
        TestPattern, parseTestPattern, testPatternMatches
    ) where

import Test.Framework.Utilities

import Text.Regex.Posix.Wrap ( (=~) )
import Text.Regex.Posix.String()

import Data.List ( inits, intersperse )


data Token = SlashToken
           | WildcardToken
           | DoubleWildcardToken
           | LiteralToken Char
           deriving (Token -> Token -> Bool
(Token -> Token -> Bool) -> (Token -> Token -> Bool) -> Eq Token
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
/= :: Token -> Token -> Bool
Eq)

tokenize :: String -> [Token]
tokenize :: String -> [Token]
tokenize (Char
'/':String
rest)     = Token
SlashToken Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
tokenize String
rest
tokenize (Char
'*':Char
'*':String
rest) = Token
DoubleWildcardToken Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
tokenize String
rest
tokenize (Char
'*':String
rest)     = Token
WildcardToken Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
tokenize String
rest
tokenize (Char
c:String
rest)       = Char -> Token
LiteralToken Char
c Token -> [Token] -> [Token]
forall a. a -> [a] -> [a]
: String -> [Token]
tokenize String
rest
tokenize []             = []


data TestPatternMatchMode = TestMatchMode
                          | PathMatchMode

data TestPattern = TestPattern {
        TestPattern -> Bool
tp_categories_only :: Bool,
        TestPattern -> Bool
tp_negated :: Bool,
        TestPattern -> TestPatternMatchMode
tp_match_mode :: TestPatternMatchMode,
        TestPattern -> [Token]
tp_tokens :: [Token]
    }

instance Read TestPattern where
    readsPrec :: Int -> ReadS TestPattern
readsPrec Int
_ String
string = [(String -> TestPattern
parseTestPattern String
string, String
"")]

parseTestPattern :: String -> TestPattern
parseTestPattern :: String -> TestPattern
parseTestPattern String
string = TestPattern {
        tp_categories_only :: Bool
tp_categories_only = Bool
categories_only,
        tp_negated :: Bool
tp_negated = Bool
negated,
        tp_match_mode :: TestPatternMatchMode
tp_match_mode = TestPatternMatchMode
match_mode,
        tp_tokens :: [Token]
tp_tokens = [Token]
tokens''
    }
  where
    tokens :: [Token]
tokens = String -> [Token]
tokenize String
string
    (Bool
negated, [Token]
tokens')
      | (LiteralToken Char
'!'):[Token]
rest <- [Token]
tokens = (Bool
True, [Token]
rest)
      | Bool
otherwise                         = (Bool
False, [Token]
tokens)
    (Bool
categories_only, [Token]
tokens'')
      | ([Token]
prefix, [Token
SlashToken]) <- Int -> [Token] -> ([Token], [Token])
forall a. Int -> [a] -> ([a], [a])
splitAt ([Token] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Token]
tokens' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [Token]
tokens' = (Bool
True, [Token]
prefix)
      | Bool
otherwise                                                      = (Bool
False, [Token]
tokens')
    match_mode :: TestPatternMatchMode
match_mode
      | Token
SlashToken Token -> [Token] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Token]
tokens = TestPatternMatchMode
PathMatchMode
      | Bool
otherwise                = TestPatternMatchMode
TestMatchMode


testPatternMatches :: TestPattern -> [String] -> Bool
testPatternMatches :: TestPattern -> [String] -> Bool
testPatternMatches TestPattern
test_pattern [String]
path = Bool -> Bool
not_maybe (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall source source1 target.
(RegexMaker Regex CompOption ExecOption source,
 RegexContext Regex source1 target) =>
source1 -> source -> target
=~ String
tokens_regex) [String]
things_to_match
  where
    not_maybe :: Bool -> Bool
not_maybe | TestPattern -> Bool
tp_negated TestPattern
test_pattern = Bool -> Bool
not
              | Bool
otherwise               = Bool -> Bool
forall a. a -> a
id
    path_to_consider :: [String]
path_to_consider | TestPattern -> Bool
tp_categories_only TestPattern
test_pattern = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
dropLast Int
1 [String]
path
                     | Bool
otherwise                       = [String]
path
    tokens_regex :: String
tokens_regex = [Token] -> String
buildTokenRegex (TestPattern -> [Token]
tp_tokens TestPattern
test_pattern)

    things_to_match :: [String]
things_to_match = case TestPattern -> TestPatternMatchMode
tp_match_mode TestPattern
test_pattern of
        -- See if the tokens match any single path component
        TestPatternMatchMode
TestMatchMode -> [String]
path_to_consider
        -- See if the tokens match any prefix of the path
        TestPatternMatchMode
PathMatchMode -> ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
pathToString ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]]
forall a. [a] -> [[a]]
inits [String]
path_to_consider


buildTokenRegex :: [Token] -> String
buildTokenRegex :: [Token] -> String
buildTokenRegex [] = []
buildTokenRegex (Token
token:[Token]
tokens) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Token -> String
firstTokenToRegex Token
token String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Token -> String) -> [Token] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Token -> String
tokenToRegex [Token]
tokens)
  where
    firstTokenToRegex :: Token -> String
firstTokenToRegex Token
SlashToken = String
"^"
    firstTokenToRegex Token
other = Token -> String
tokenToRegex Token
other

    tokenToRegex :: Token -> String
tokenToRegex Token
SlashToken = String
"/"
    tokenToRegex Token
WildcardToken = String
"[^/]*"
    tokenToRegex Token
DoubleWildcardToken = String
"*"
    tokenToRegex (LiteralToken Char
lit) = Char -> String
regexEscapeChar Char
lit

regexEscapeChar :: Char -> String
regexEscapeChar :: Char -> String
regexEscapeChar Char
c | Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"\\*+?|{}[]()^$." = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: [Char
c]
                  | Bool
otherwise                  = [Char
c]

pathToString :: [String] -> String
pathToString :: [String] -> String
pathToString [String]
path = String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"/" [String]
path)