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