| rev |
line source |
|
tonyg@70
|
1 module Matcher where
|
|
tonyg@53
|
2
|
|
tonyg@53
|
3 import Text.ParserCombinators.Parsec as Parsec
|
|
tonyg@53
|
4 import qualified Text.ParserCombinators.Parsec.Token as P
|
|
tonyg@59
|
5 import qualified List
|
|
tonyg@77
|
6 import qualified Maybe
|
|
tonyg@59
|
7 import Debug.Trace
|
|
tonyg@59
|
8
|
|
tonyg@64
|
9 type Env = [(Bool, String, Value)]
|
|
tonyg@59
|
10
|
|
tonyg@59
|
11 data AST = AstAtom String
|
|
tonyg@90
|
12 | AstLiteral Literal
|
|
tonyg@65
|
13 | AstBinding String AST
|
|
tonyg@61
|
14 | AstDiscard
|
|
tonyg@74
|
15 | AstObject [(AST, AST)]
|
|
tonyg@64
|
16 | AstLet String AST
|
|
tonyg@59
|
17 | AstApp AST AST
|
|
tonyg@59
|
18 deriving (Eq, Ord)
|
|
tonyg@53
|
19
|
|
tonyg@90
|
20 data Literal = LitInt Integer
|
|
tonyg@90
|
21 deriving (Eq, Ord)
|
|
tonyg@90
|
22
|
|
tonyg@53
|
23 data Value = VAtom String
|
|
tonyg@90
|
24 | VLiteral Literal
|
|
tonyg@65
|
25 | VBinding String Value
|
|
tonyg@61
|
26 | VDiscard
|
|
tonyg@89
|
27 | VObject [(Value, Closure)]
|
|
tonyg@91
|
28 | VPrimitive Primitive
|
|
tonyg@53
|
29 deriving (Eq, Ord)
|
|
tonyg@53
|
30
|
|
tonyg@91
|
31 data Primitive = Primitive String (Value -> Value)
|
|
tonyg@91
|
32
|
|
tonyg@60
|
33 data Closure = Closure Env AST
|
|
tonyg@65
|
34 | Constant Value
|
|
tonyg@60
|
35 deriving (Eq, Ord)
|
|
tonyg@60
|
36
|
|
tonyg@53
|
37 tngDef = P.LanguageDef
|
|
tonyg@53
|
38 { P.commentStart = "\""
|
|
tonyg@53
|
39 , P.commentEnd = "\""
|
|
tonyg@53
|
40 , P.commentLine = ""
|
|
tonyg@53
|
41 , P.nestedComments = False
|
|
tonyg@53
|
42 , P.identStart = letter
|
|
tonyg@53
|
43 , P.identLetter = alphaNum
|
|
tonyg@53
|
44 , P.opStart = (oneOf ":!#$%&*+./<=>?@\\^|-~")
|
|
tonyg@53
|
45 , P.opLetter = (oneOf ":!#$%&*+./<=>?@\\^|-~" <|> alphaNum)
|
|
tonyg@53
|
46 , P.reservedNames = []
|
|
tonyg@53
|
47 , P.reservedOpNames = []
|
|
tonyg@53
|
48 , P.caseSensitive = True
|
|
tonyg@53
|
49 }
|
|
tonyg@53
|
50
|
|
tonyg@53
|
51 tngTokenizer = P.makeTokenParser tngDef
|
|
tonyg@53
|
52
|
|
tonyg@53
|
53 whiteSpace = P.whiteSpace tngTokenizer
|
|
tonyg@53
|
54 ident = P.identifier tngTokenizer
|
|
tonyg@53
|
55 integer = P.integer tngTokenizer
|
|
tonyg@53
|
56 punct s = do string s; whiteSpace; return ()
|
|
tonyg@92
|
57 operator = P.operator tngTokenizer
|
|
tonyg@92
|
58 comma = P.comma tngTokenizer
|
|
tonyg@53
|
59
|
|
tonyg@59
|
60 readAST = readApp
|
|
tonyg@59
|
61 readApp = do (part : parts) <- sepBy1 readSimple whiteSpace; return $ foldl AstApp part parts
|
|
tonyg@92
|
62 readSquare = try (do entries <- sepBy readMapEntry whiteSpace; return $ AstObject entries)
|
|
tonyg@92
|
63 <|> try (do entries <- sepBy readApp comma; return $ buildList entries)
|
|
tonyg@53
|
64 readMapEntry = do l <- readSimple; punct ":"; r <- readSimple; return (l, r)
|
|
tonyg@59
|
65 readSimple = do punct "("; v <- readAST; punct ")"; return v
|
|
tonyg@92
|
66 <|> do punct "["; m <- readSquare; punct "]"; return m
|
|
tonyg@76
|
67 <|> do string "+"; i <- ident; readBinding i
|
|
tonyg@61
|
68 <|> do punct "_"; return AstDiscard
|
|
tonyg@90
|
69 <|> do i <- integer; return $ AstLiteral $ LitInt i
|
|
tonyg@64
|
70 <|> do i <- ident; readLet i
|
|
tonyg@64
|
71 readLet i = do punct "="; v <- readSimple; return $ AstLet i v
|
|
tonyg@64
|
72 <|> (return $ AstAtom i)
|
|
tonyg@65
|
73 readBinding i = do punct "@"; v <- readSimple; return $ AstBinding i v
|
|
tonyg@65
|
74 <|> (return $ AstBinding i AstDiscard)
|
|
tonyg@59
|
75
|
|
tonyg@92
|
76 buildList [] = AstObject []
|
|
tonyg@92
|
77 buildList (x:xs) = (AstAtom "cons" `AstApp` x) `AstApp` buildList xs
|
|
tonyg@92
|
78
|
|
tonyg@60
|
79 sepList s [] = ""
|
|
tonyg@60
|
80 sepList s [x] = x
|
|
tonyg@60
|
81 sepList s (x:xs) = x ++ s ++ sepList s xs
|
|
tonyg@60
|
82
|
|
tonyg@59
|
83 showClause (l, r) = show l ++ ": " ++ show r
|
|
tonyg@60
|
84 showClauses clauses = sepList " " (map showClause clauses)
|
|
tonyg@59
|
85
|
|
tonyg@59
|
86 instance Show AST where
|
|
tonyg@59
|
87 show v = showAST v
|
|
tonyg@59
|
88
|
|
tonyg@59
|
89 showAST (AstAtom s) = s
|
|
tonyg@90
|
90 showAST (AstLiteral l) = show l
|
|
tonyg@65
|
91 showAST (AstBinding s AstDiscard) = "+" ++ s
|
|
tonyg@65
|
92 showAST (AstBinding s v) = "+" ++ s ++ "@" ++ show v
|
|
tonyg@61
|
93 showAST (AstDiscard) = "_"
|
|
tonyg@74
|
94 showAST (AstObject clauses) = "[" ++ showClauses clauses ++ "]"
|
|
tonyg@64
|
95 showAST (AstLet s v) = s ++ "=" ++ show v
|
|
tonyg@59
|
96 showAST (AstApp v1 v2) = "(" ++ show v1 ++ " " ++ show v2 ++ ")"
|
|
tonyg@53
|
97
|
|
tonyg@90
|
98 instance Show Literal where
|
|
tonyg@90
|
99 show l = showLiteral l
|
|
tonyg@90
|
100
|
|
tonyg@90
|
101 showLiteral (LitInt i) = show i
|
|
tonyg@90
|
102
|
|
tonyg@53
|
103 instance Show Value where
|
|
tonyg@53
|
104 show v = showValue v
|
|
tonyg@53
|
105
|
|
tonyg@53
|
106 showValue (VAtom s) = s
|
|
tonyg@90
|
107 showValue (VLiteral l) = show l
|
|
tonyg@65
|
108 showValue (VBinding s VDiscard) = "+" ++ s
|
|
tonyg@65
|
109 showValue (VBinding s v) = "+" ++ s ++ "@" ++ show v
|
|
tonyg@61
|
110 showValue (VDiscard) = "_"
|
|
tonyg@60
|
111 showValue (VObject clauses) = "[" ++ showClauses clauses ++ "]"
|
|
tonyg@91
|
112 showValue (VPrimitive p) = show p
|
|
tonyg@91
|
113
|
|
tonyg@91
|
114 instance Eq Primitive where
|
|
tonyg@91
|
115 (Primitive n1 _) == (Primitive n2 _) = n1 == n2
|
|
tonyg@91
|
116
|
|
tonyg@91
|
117 instance Ord Primitive where
|
|
tonyg@91
|
118 (Primitive n1 _) `compare` (Primitive n2 _) = n1 `compare` n2
|
|
tonyg@91
|
119
|
|
tonyg@91
|
120 instance Show Primitive where
|
|
tonyg@91
|
121 show (Primitive name _) = "#<" ++ name ++ ">"
|
|
tonyg@53
|
122
|
|
tonyg@60
|
123 instance Show Closure where
|
|
tonyg@60
|
124 show (Closure e v) = showEnv e ++ show v
|
|
tonyg@65
|
125 show (Constant v) = show v
|
|
tonyg@60
|
126
|
|
tonyg@64
|
127 showEnvEntry (False, n, v) = n ++ "->" ++ show v
|
|
tonyg@64
|
128 showEnvEntry (True, n, v) = n
|
|
tonyg@60
|
129 showEnv [] = ""
|
|
tonyg@60
|
130 showEnv bindings = "{" ++ sepList ", " (map showEnvEntry bindings) ++ "} "
|
|
tonyg@59
|
131
|
|
tonyg@59
|
132 parseASTFromString = parse (do whiteSpace; v <- readAST; eof; return v) ""
|
|
tonyg@59
|
133
|
|
tonyg@59
|
134 readTng s = case parseASTFromString s of
|
|
tonyg@59
|
135 Right v -> v
|
|
tonyg@59
|
136 Left err -> error $ "Parse error: " ++ show err
|
|
tonyg@53
|
137
|
|
tonyg@53
|
138 ---------------------------------------------------------------------------
|
|
tonyg@53
|
139
|
|
tonyg@83
|
140 eLookup s [] defval = defval
|
|
tonyg@83
|
141 eLookup s ((_, n, v):bs) defval = if n == s then v else eLookup s bs defval
|
|
tonyg@83
|
142 lookupVal s bs = eLookup s bs (eLookup s baseEnv (VAtom s))
|
|
tonyg@60
|
143
|
|
tonyg@89
|
144 -- match pattern value -> maybe bindings
|
|
tonyg@89
|
145 match (VAtom a) (VAtom b) = if a == b then Just [] else Nothing
|
|
tonyg@90
|
146 match (VLiteral a) (VLiteral b) = if a == b then Just [] else Nothing
|
|
tonyg@89
|
147 match (VBinding n p) v = do bs <- match p v; return ((False, n, v) : bs)
|
|
tonyg@89
|
148 match (VDiscard) v = Just []
|
|
tonyg@89
|
149 match (VObject patternClauses) (VObject valueClauses) =
|
|
tonyg@60
|
150 foldr bindingUnion (Just []) $ map (match1 valueClauses) patternClauses
|
|
tonyg@72
|
151 where bindingUnion j1 j2 = do b1 <- j1; b2 <- j2; return (b1 ++ b2)
|
|
tonyg@91
|
152 match (VPrimitive (Primitive n1 _)) (VPrimitive (Primitive n2 _)) = if n1 == n2 then Just [] else Nothing
|
|
tonyg@53
|
153 match _ _ = Nothing
|
|
tonyg@53
|
154
|
|
tonyg@60
|
155 firstThat p [] = Nothing
|
|
tonyg@60
|
156 firstThat p (x:xs) = case p x of
|
|
tonyg@60
|
157 Nothing -> firstThat p xs
|
|
tonyg@60
|
158 j -> j
|
|
tonyg@60
|
159
|
|
tonyg@60
|
160 match1 valueClauses (pval, ppat) =
|
|
tonyg@60
|
161 firstThat firstMatch valueClauses
|
|
tonyg@60
|
162 where firstMatch (vpat, vval) =
|
|
tonyg@60
|
163 do bs' <- match vpat pval
|
|
tonyg@89
|
164 bs'' <- match (forcePattern ppat) (reduce vval bs')
|
|
tonyg@60
|
165 return bs''
|
|
tonyg@60
|
166
|
|
tonyg@89
|
167 forcePattern clo = reduce clo []
|
|
tonyg@65
|
168
|
|
tonyg@60
|
169 reduce (Closure env v) bs = eval (bs ++ env) v
|
|
tonyg@65
|
170 reduce (Constant v) bs = v
|
|
tonyg@53
|
171
|
|
tonyg@59
|
172 eval bs o =
|
|
tonyg@59
|
173 case o of
|
|
tonyg@60
|
174 AstAtom s -> lookupVal s bs
|
|
tonyg@90
|
175 AstLiteral l -> VLiteral l
|
|
tonyg@65
|
176 AstBinding s v -> VBinding s (eval bs v)
|
|
tonyg@61
|
177 AstDiscard -> VDiscard
|
|
tonyg@74
|
178 AstObject clauses -> VObject $ map evalClause clauses
|
|
tonyg@74
|
179 where evalClause (patexp, val) = (pat, maybeClose pat bs val)
|
|
tonyg@89
|
180 where pat = eval bs patexp
|
|
tonyg@64
|
181 AstLet s v -> result
|
|
tonyg@64
|
182 where result = eval bs' v
|
|
tonyg@64
|
183 bs' = (True, s, result) : bs
|
|
tonyg@59
|
184 AstApp rator rand -> applyTng bs (eval bs rator) (eval bs rand)
|
|
tonyg@53
|
185
|
|
tonyg@65
|
186 maybeClose pat bs o =
|
|
tonyg@66
|
187 case patBound pat of
|
|
tonyg@66
|
188 [] -> Constant $ eval bs o
|
|
tonyg@65
|
189 _ -> Closure bs o
|
|
tonyg@65
|
190
|
|
tonyg@89
|
191 patBound (VAtom s) = []
|
|
tonyg@90
|
192 patBound (VLiteral l) = []
|
|
tonyg@89
|
193 patBound (VBinding s p) = [s] ++ patBound p
|
|
tonyg@89
|
194 patBound (VDiscard) = []
|
|
tonyg@89
|
195 patBound (VObject clauses) = concatMap clauseBound clauses
|
|
tonyg@89
|
196 where clauseBound (_, clo) = patBound $ forcePattern clo
|
|
tonyg@91
|
197 patBound (VPrimitive (Primitive n _)) = []
|
|
tonyg@65
|
198
|
|
tonyg@60
|
199 dnu function value = error $ "DNU: " ++ show function ++ " " ++ show value
|
|
tonyg@53
|
200
|
|
tonyg@60
|
201 applyTng bs function@(VObject patternClauses) value =
|
|
tonyg@60
|
202 case firstThat matches patternClauses of
|
|
tonyg@60
|
203 Nothing -> dnu function value
|
|
tonyg@60
|
204 Just result -> result
|
|
tonyg@60
|
205 where matches (ppat, pval) = case match ppat value of
|
|
tonyg@60
|
206 Nothing -> Nothing
|
|
tonyg@60
|
207 Just bs' -> Just $ reduce pval bs'
|
|
tonyg@91
|
208 applyTng bs function@(VPrimitive (Primitive _ f)) value = f value
|
|
tonyg@62
|
209 applyTng bs function value = dnu function value
|
|
tonyg@59
|
210
|
|
tonyg@70
|
211 ---------------------------------------------------------------------------
|
|
tonyg@70
|
212
|
|
tonyg@77
|
213 infix 4 <: -- accepts strictly more values
|
|
tonyg@77
|
214 infix 4 <=: -- either <: or =:
|
|
tonyg@77
|
215 infix 4 =: -- is essentially "the same" pattern
|
|
tonyg@73
|
216
|
|
tonyg@77
|
217 (=:) = patEqv
|
|
tonyg@77
|
218 (<:) = stricter
|
|
tonyg@77
|
219 p1 <=: p2 = (p1 <: p2) || (p1 =: p2)
|
|
tonyg@73
|
220
|
|
tonyg@77
|
221 p1 `overlaps` p2 = (p1 <: p2) || (p1 =: p2) || (p2 <: p1)
|
|
tonyg@73
|
222
|
|
tonyg@89
|
223 patEqv (VAtom s1) (VAtom s2) = s1 == s2
|
|
tonyg@90
|
224 patEqv (VLiteral l1) (VLiteral l2) = l1 == l2
|
|
tonyg@89
|
225 patEqv (VDiscard) (VDiscard) = True
|
|
tonyg@89
|
226 patEqv (VBinding s p1) p2 = patEqv p1 p2
|
|
tonyg@89
|
227 patEqv p1 (VBinding s p2) = patEqv p1 p2
|
|
tonyg@89
|
228 patEqv (VObject c1) (VObject c2) = clausesMatchBy c1 c2 && clausesMatchBy c2 c1
|
|
tonyg@91
|
229 patEqv (VPrimitive (Primitive n1 _)) (VPrimitive (Primitive n2 _)) = n1 == n2
|
|
tonyg@77
|
230 patEqv _ _ = False
|
|
tonyg@77
|
231
|
|
tonyg@89
|
232 clauseEqv (v1, p1) (v2, p2) = (v1 `patEqv` v2) && (forcePattern p1 `patEqv` forcePattern p2)
|
|
tonyg@77
|
233
|
|
tonyg@79
|
234 clausesMatchBy c1 c2 = null $ remaining
|
|
tonyg@77
|
235 where remaining = foldl removeClauses c2 c1
|
|
tonyg@79
|
236 removeClauses cs c = filter (not . clauseEqv c) cs
|
|
tonyg@77
|
237
|
|
tonyg@89
|
238 stricter (VBinding s p1) p2 = stricter p1 p2
|
|
tonyg@89
|
239 stricter p1 (VBinding s p2) = stricter p1 p2
|
|
tonyg@81
|
240 stricter a b | a == b = False
|
|
tonyg@89
|
241 stricter _ (VDiscard) = True
|
|
tonyg@89
|
242 stricter (VObject c1) (VObject c2) = any (surviveAfterRemoving c2) c1 &&
|
|
tonyg@81
|
243 not (any (surviveAfterRemoving c1) c2)
|
|
tonyg@81
|
244 where surviveAfterRemoving clausesToRemove clause =
|
|
tonyg@81
|
245 not $ any (`clauseStricterOrEqv` clause) clausesToRemove
|
|
tonyg@81
|
246 stricter _ _ = False
|
|
tonyg@81
|
247
|
|
tonyg@81
|
248 clauseStricterOrEqv c1 c2 = (c1 `clauseStricter` c2) || (c1 `clauseEqv` c2)
|
|
tonyg@81
|
249
|
|
tonyg@89
|
250 clauseStricter (v1, p1) (v2, p2) = ((v1 `valEqv` v2) && (p1' `stricter` p2')) ||
|
|
tonyg@89
|
251 ((v1 `coStricter` v2) && ((p1' `stricter` p2') ||
|
|
tonyg@89
|
252 (p1' `patEqv` p2')))
|
|
tonyg@89
|
253 where v1 `coStricter` v2 = (v2 `stricter` v1)
|
|
tonyg@89
|
254 v1 `valEqv` v2 = (v1 `patEqv` v2)
|
|
tonyg@89
|
255 p1' = forcePattern p1
|
|
tonyg@89
|
256 p2' = forcePattern p2
|
|
tonyg@81
|
257
|
|
tonyg@81
|
258 ---------------------------------------------------------------------------
|
|
tonyg@81
|
259
|
|
tonyg@81
|
260 infix 4 <::
|
|
tonyg@81
|
261 infix 4 <=::
|
|
tonyg@81
|
262 infix 4 =::
|
|
tonyg@81
|
263
|
|
tonyg@89
|
264 a <:: b = (eval' a) <: (eval' b)
|
|
tonyg@89
|
265 a <=:: b = (eval' a) <=: (eval' b)
|
|
tonyg@89
|
266 a =:: b = (eval' a) =: (eval' b)
|
|
tonyg@81
|
267
|
|
tonyg@89
|
268 data Failure = Failure { lhs :: Value, rhs :: Value, expected :: Bool, got :: Bool }
|
|
tonyg@77
|
269 deriving (Show)
|
|
tonyg@77
|
270 strictFailures = Maybe.mapMaybe fails tests
|
|
tonyg@77
|
271 where fails (lhs, rhs, expected) = let result = (lhs <:: rhs) in
|
|
tonyg@77
|
272 if result == expected
|
|
tonyg@77
|
273 then Nothing
|
|
tonyg@89
|
274 else Just $ Failure { lhs = eval' lhs,
|
|
tonyg@89
|
275 rhs = eval' rhs,
|
|
tonyg@77
|
276 expected = expected,
|
|
tonyg@77
|
277 got = result }
|
|
tonyg@77
|
278 tests = [("cons _ (cons _ _)", "cons (cons _ _) _", False),
|
|
tonyg@77
|
279 ("cons _ (cons _ _)", "cons _ _", True),
|
|
tonyg@77
|
280 ("cons _ _", "cons _ (cons _ _)", False),
|
|
tonyg@77
|
281 ("[]", "[]", False),
|
|
tonyg@77
|
282 ("[]", "cons _ _", False),
|
|
tonyg@77
|
283 ("cons _ _", "cons _ _", False),
|
|
tonyg@77
|
284 ("cons +a +b", "cons +c +d", False),
|
|
tonyg@77
|
285 ("[First: _]", "[First: _ Rest: _]", False),
|
|
tonyg@77
|
286 ("[A: _ B: _]", "[B: _ A: _]", False),
|
|
tonyg@77
|
287 ("[A: _ B: _]", "[A: _]", True),
|
|
tonyg@77
|
288 ("[A: _ B: _]", "[C: _]", False),
|
|
tonyg@77
|
289 ("[A: _ B: _]", "[C: _ A: _]", False),
|
|
tonyg@77
|
290 ("[First: _ Rest: _]", "[First: _]", True)]
|
|
tonyg@77
|
291
|
|
tonyg@73
|
292 ---------------------------------------------------------------------------
|
|
tonyg@73
|
293
|
|
tonyg@70
|
294 eval' exp = eval [] (readTng exp)
|
|
tonyg@70
|
295
|
|
tonyg@63
|
296 baseEnv = [ def "cons" "[+car: [+cdr: [First: car Rest: cdr]]]"
|
|
tonyg@92
|
297 , def "map" "[+f: loop=[(cons +a +d): (cons (f a) (loop d)) +x: x]]"
|
|
tonyg@91
|
298 , defPrim "add" $ \(VLiteral (LitInt i)) -> p $ \(VLiteral (LitInt j)) -> VLiteral (LitInt (i + j))
|
|
tonyg@63
|
299 ]
|
|
tonyg@91
|
300 where def nm exp = def' nm $ eval' exp
|
|
tonyg@91
|
301 def' nm val = (False, nm, val)
|
|
tonyg@91
|
302 p fn = VPrimitive $ Primitive "(anon)" fn
|
|
tonyg@91
|
303 defPrim nm fn = def' nm $ VPrimitive $ Primitive nm fn
|
