File: TestPattern.hs

package info (click to toggle)
haskell-test-framework 0.6-1
  • links: PTS, VCS
  • area: main
  • in suites: wheezy
  • size: 176 kB
  • sloc: haskell: 928; makefile: 2
file content (93 lines) | stat: -rw-r--r-- 3,147 bytes parent folder | download | duplicates (7)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
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


data Token = SlashToken
           | WildcardToken
           | DoubleWildcardToken
           | LiteralToken Char
           deriving (Eq)

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


data TestPatternMatchMode = TestMatchMode
                          | PathMatchMode

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

instance Read TestPattern where
    readsPrec _ string = [(parseTestPattern string, "")]

parseTestPattern :: String -> TestPattern
parseTestPattern string = TestPattern {
        tp_categories_only = categories_only,
        tp_negated = negated,
        tp_match_mode = match_mode,
        tp_tokens = tokens''
    }
  where
    tokens = tokenize string
    (negated, tokens')
      | (LiteralToken '!'):rest <- tokens = (True, rest)
      | otherwise                         = (False, tokens)
    (categories_only, tokens'')
      | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix)
      | otherwise                                                      = (False, tokens')
    match_mode
      | SlashToken `elem` tokens = PathMatchMode
      | otherwise                = TestMatchMode


testPatternMatches :: TestPattern -> [String] -> Bool
testPatternMatches test_pattern path = not_maybe $ any (=~ tokens_regex) things_to_match
  where
    not_maybe | tp_negated test_pattern = not
              | otherwise               = id
    path_to_consider | tp_categories_only test_pattern = dropLast 1 path
                     | otherwise                       = path
    tokens_regex = buildTokenRegex (tp_tokens test_pattern)
    
    things_to_match = case tp_match_mode test_pattern of
        -- See if the tokens match any single path component
        TestMatchMode -> path_to_consider
        -- See if the tokens match any prefix of the path
        PathMatchMode -> map pathToString $ inits path_to_consider


buildTokenRegex :: [Token] -> String
buildTokenRegex [] = []
buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens)
  where
    firstTokenToRegex SlashToken = "^"
    firstTokenToRegex other = tokenToRegex other
      
    tokenToRegex SlashToken = "/"
    tokenToRegex WildcardToken = "[^/]*"
    tokenToRegex DoubleWildcardToken = "*"
    tokenToRegex (LiteralToken lit) = regexEscapeChar lit

regexEscapeChar :: Char -> String
regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c]
                  | otherwise                  = [c]

pathToString :: [String] -> String
pathToString path = "/" ++ concat (intersperse "/" path)