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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
{- A generic matcher.
-
- Can be used to check if a user-supplied condition,
- like "foo and ( bar or not baz )" matches. The condition must already
- be tokenized, and can contain arbitrary operations.
-
- If operations are not separated by and/or, they are defaulted to being
- anded together, so "foo bar baz" all must match.
-
- Is forgiving about misplaced closing parens, so "foo and (bar or baz"
- will be handled, as will "foo and ( bar or baz ) )"
-
- Copyright 2011-2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE Rank2Types, KindSignatures #-}
module Utility.Matcher (
Token(..),
Matcher,
token,
tokens,
generate,
match,
matchM,
matchMrun,
isEmpty,
prop_matcher_sane
) where
import Common
{- A Token can be an Operation of an arbitrary type, or one of a few
- predefined peices of syntax. -}
data Token op = Operation op | And | Or | Not | Open | Close
deriving (Show, Eq)
data Matcher op = MAny
| MAnd (Matcher op) (Matcher op)
| MOr (Matcher op) (Matcher op)
| MNot (Matcher op)
| MOp op
deriving (Show, Eq)
{- Converts a word of syntax into a token. Doesn't handle operations. -}
token :: String -> Token op
token "and" = And
token "or" = Or
token "not" = Not
token "(" = Open
token ")" = Close
token t = error $ "unknown token " ++ t
tokens :: [String]
tokens = words "and or not ( )"
{- Converts a list of Tokens into a Matcher. -}
generate :: [Token op] -> Matcher op
generate = simplify . process MAny . tokenGroups
where
process m [] = m
process m ts = uncurry process $ consume m ts
consume m ((One And):rest) = term (m `MAnd`) rest
consume m ((One Or):rest) = term (m `MOr`) rest
consume m ((One Not):rest) = term (\p -> m `MAnd` (MNot p)) rest
consume m ((One (Operation o)):rest) = (m `MAnd` MOp o, rest)
consume m (Group g:rest) = (process m g, rest)
consume m (_:rest) = consume m rest
consume m [] = (m, [])
term a l =
let (p, l') = consume MAny l
in (a p, l')
simplify (MAnd MAny x) = simplify x
simplify (MAnd x MAny) = simplify x
simplify (MAnd x y) = MAnd (simplify x) (simplify y)
simplify (MOr x y) = MOr (simplify x) (simplify y)
simplify (MNot x) = MNot (simplify x)
simplify x = x
data TokenGroup op = One (Token op) | Group [TokenGroup op]
deriving (Show, Eq)
tokenGroups :: [Token op] -> [TokenGroup op]
tokenGroups [] = []
tokenGroups (t:ts) = go t
where
go Open =
let (gr, rest) = findClose ts
in gr : tokenGroups rest
go Close = tokenGroups ts -- not picky about missing Close
go _ = One t : tokenGroups ts
findClose :: [Token op] -> (TokenGroup op, [Token op])
findClose l =
let (g, rest) = go [] l
in (Group (reverse g), rest)
where
go c [] = (c, []) -- not picky about extra Close
go c (t:ts) = handle t
where
handle Close = (c, ts)
handle Open =
let (c', ts') = go [] ts
in go (Group (reverse c') : c) ts'
handle _ = go (One t:c) ts
{- Checks if a Matcher matches, using a supplied function to check
- the value of Operations. -}
match :: (op -> v -> Bool) -> Matcher op -> v -> Bool
match a m v = go m
where
go MAny = True
go (MAnd m1 m2) = go m1 && go m2
go (MOr m1 m2) = go m1 || go m2
go (MNot m1) = not $ go m1
go (MOp o) = a o v
{- Runs a monadic Matcher, where Operations are actions in the monad. -}
matchM :: Monad m => Matcher (v -> m Bool) -> v -> m Bool
matchM m v = matchMrun m $ \o -> o v
{- More generic running of a monadic Matcher, with full control over running
- of Operations. Mostly useful in order to match on more than one
- parameter. -}
matchMrun :: forall o (m :: * -> *). Monad m => Matcher o -> (o -> m Bool) -> m Bool
matchMrun m run = go m
where
go MAny = return True
go (MAnd m1 m2) = go m1 <&&> go m2
go (MOr m1 m2) = go m1 <||> go m2
go (MNot m1) = liftM not (go m1)
go (MOp o) = run o
{- Checks if a matcher contains no limits. -}
isEmpty :: Matcher a -> Bool
isEmpty MAny = True
isEmpty _ = False
prop_matcher_sane :: Bool
prop_matcher_sane = all (\m -> match dummy m ()) $ map generate
[ [Operation True]
, []
, [Operation False, Or, Operation True, Or, Operation False]
, [Operation True, Or, Operation True]
, [Operation True, And, Operation True]
, [Not, Open, Operation True, And, Operation False, Close]
, [Not, Open, Not, Open, Not, Operation False, Close, Close]
, [Not, Open, Not, Open, Not, Open, Not, Operation True, Close, Close]
, [Operation True, And, Not, Operation False]
, [Operation True, Not, Operation False]
, [Operation True, Not, Not, Not, Operation False]
, [Operation True, Not, Not, Not, Operation False, And, Operation True]
, [Operation True, Not, Not, Not, Operation False, Operation True]
, [Not, Open, Operation True, And, Operation False, Close,
And, Open,
Open, Operation True, And, Operation False, Close,
Or,
Open, Operation True, And, Open, Not, Operation False, Close, Close,
Close, And,
Open, Not, Operation False, Close]
]
where
dummy b _ = b
|
