smalltalk-tng
view etng-r1/coreetng.hs @ 321:c4a0718c2d3c
Sketch of dependencies
| author | Tony Garnock-Jones <tonygarnockjones@gmail.com> |
|---|---|
| date | Sat Oct 08 15:36:03 2011 -0400 (7 months ago) |
| parents | 3cd5df5120a2 |
| children |
line source
1 module CoreETng where
3 ---------------------------------------------------------------------------
4 -- If you don't want to support *groups* of clauses natively, then
5 -- rewrite them to share a binding for self/super.
6 --
7 -- [.x=.result]
8 -- + [.y=.foo, .b=self.y]
9 -- + [vv=[1=vv]]
10 --
11 -- becomes
12 --
13 -- [.x=.result]
14 -- + [msg = [xself = [xsuper = [.y=.foo] + [.b=xself.y] + [other=xsuper other]]] self super msg]
15 -- + [vv=[1=vv]]
16 ---------------------------------------------------------------------------
17 -- It's clear that messages (<exp1 exp2 ...>) can be rewritten into
18 -- regular closures (let val1 = exp1 in let val2 = exp2 in
19 -- ... {receiver -> receiver val1 val2 ...}). Message patterns can be
20 -- rewritten, too:
21 --
22 -- [<pat1 pat2 ...> = exp]
23 --
24 -- becomes (using {} for closure-clauses, as for the full eTNG)
25 --
26 -- [msg -> msg {pat1 -> {pat2 -> {... -> exp}}}]
27 --
28 -- Note there's no default clause {_ -> super msg} here. That's up to
29 -- the user. We don't automatically backtrack.
30 --
31 -- Of course, adjacent clauses in a group need to be rewritten
32 -- carefully:
33 --
34 -- [.x 1 -> .a;
35 -- .x 2 -> .b;
36 -- <.c 1> -> .z;
37 -- <.c 2> -> .w;
38 -- v -> v]
39 --
40 -- becomes
41 --
42 -- [.x -> {1 -> .a;
43 -- 2 -> .b};
44 -- msg -> msg {.c -> {1 -> .z; "where msg is fresh"
45 -- 2 -> .w};
46 -- _ -> [v -> v] msg}]
47 --
48 -- Eww. I don't think that last catch-all line is a good idea. It
49 -- should probably be illegal to to have multiple catch-all clauses in
50 -- a group that can't be merged - so either the <.c ...>'s or the v->v
51 -- would need to be removed to make that legal. This decision is in
52 -- keeping with the don't-backtrack principle. Assuming we remove the
53 -- v->v from the example, the result becomes
54 --
55 -- [.x -> {1 -> .a;
56 -- 2 -> .b};
57 -- msg -> msg {.c -> {1 -> .z; "where msg is fresh"
58 -- 2 -> .w}}]
59 --
60 -- All this rewriting means that the debug-information used to report
61 -- DNU may need to be a set of character ranges in disjoint pieces of
62 -- code, since there'll be no single coherent place we can point to
63 -- and say "this is the receiver of the failed message"!
64 ---------------------------------------------------------------------------
65 -- Here's a piece of (pseudo-)code from test3.tng:
66 --
67 -- {<.s:empty>, <.s:empty> -> .bothEmpty;
68 -- _, <.s:empty> -> .secondEmpty;
69 -- <.s:empty>, _ -> .firstEmpty;
70 -- _, _ -> .neitherEmpty}
71 --
72 -- There are a couple of interesting things here. Our rule about never
73 -- backtracking means that some of the clauses, as written, are
74 -- unreachable. Also, the presence of tuples *containing*
75 -- message-pattern-matches could be awkward.
76 --
77 -- Let's pull out as much shared structure as possible between
78 -- neighbouring clauses - here, it's the single outermost duple - and
79 -- put fresh pattern variables in the slots where neighbours
80 -- vary. Then reinject the pattern variables *in left to right order*
81 -- using currying rather than structure. If we do things that way,
82 -- then the last two clauses above are unreachable because of the
83 -- discard in the left cell of the tuple pattern in the second clause.
84 --
85 -- {(t1, t2) -> {<.s:empty> -> {<.s:empty> -> .bothEmpty};
86 -- _ -> {<.s:empty> -> .secondEmpty};
87 -- "No other rules - the remaining clauses are unreachable!"}
88 -- t1 t2}
89 --
90 -- Simplest might be just to plain not implement message-patterns
91 -- yet. After all, any message-pattern can be easily rewritten away
92 -- into cases - less convenient, but certainly clearer:
93 --
94 -- {<.a(x)> -> x;
95 -- <.b(y)> -> y}
96 --
97 -- becomes
98 --
99 -- {value -> value {.a(x) -> x;
100 -- .b(y) -> y}}
101 --
102 -- which actually can also be written
103 --
104 -- <{.a(x) -> x;
105 -- .b(y) -> y}>
106 --
107 -- Hmm!
108 ---------------------------------------------------------------------------
110 import qualified Maybe
111 import List
113 import Text.ParserCombinators.Parsec as Parsec
114 import qualified Text.ParserCombinators.Parsec.Token as P
116 data Literal = SymLit String
117 | IntLit Integer
118 deriving Eq
120 type Varname = String
122 type Environment = [(Varname, Val)]
124 data Exp = Clause Pat Exp
125 | Send Exp Exp
126 | Extend Exp Exp
127 | TupleExp [Exp]
128 | LitExp Literal
129 | Ref Varname
130 | Self
131 | Super
133 data Pat = Discard
134 | LitPat Literal
135 | Def Varname Pat
136 | TuplePat [Pat]
138 type ClosureClause = (Environment, Pat, Exp)
140 data Val = Closure [ClosureClause]
141 | LitVal Literal
142 | TupleVal [Val]
144 ---------------------------------------------------------------------------
145 -- Evaluator
147 eval env self super = eval'
148 where eval' (Clause p e) = Closure [(env, p, e)]
149 eval' (Send e1 e2) = send (eval' e1) (eval' e2)
150 eval' (Extend e1 e2) = extendClosure (eval' e1) (eval' e2)
151 eval' (TupleExp es) = TupleVal $ map eval' es
152 eval' (LitExp l) = LitVal l
153 eval' (Ref v) = maybe (unboundvariable v) id (lookup v env)
154 eval' Self = self
155 eval' Super = super
157 send receiver@(Closure clauses) message = search clauses
158 where search [] = doesnotunderstand receiver message
159 search ((env, pat, body):rest) = maybe (search rest) deliver (match pat message)
160 where deliver bindings = eval (bindings ++ env) receiver (Closure rest) body
161 send receiver message = error $ "PrimitiveReceiver:" ++ show (receiver, message)
163 match Discard _ = Just []
164 match (LitPat l1) (LitVal l2)
165 | l1 == l2 = Just []
166 | otherwise = Nothing
167 match (Def v p) val = maybe Nothing (\inner -> Just ((v,val):inner)) (match p val)
168 match (TuplePat ps) (TupleVal vs)
169 | length ps /= length vs = Nothing
170 | otherwise = foldr accumulate (Just []) $ zip ps vs
171 where accumulate _ Nothing = Nothing
172 accumulate (p, v) (Just rightBindings) =
173 maybe Nothing (\inner -> Just (inner ++ rightBindings)) (match p v)
174 match _ _ = Nothing
176 extendClosure (Closure c1) (Closure c2) = Closure (c1 ++ c2)
177 extendClosure c@(Closure _) _ = c
178 extendClosure _ any = any
180 doesnotunderstand receiver message = error $ "DNU:" ++ show (receiver, message)
181 unboundvariable v = error $ "Unbound:" ++ show v
183 ---------------------------------------------------------------------------
184 -- Reasoning
186 freeIn (Clause p e) = freeIn e \\ boundIn p
187 freeIn (Send e1 e2) = freeIn e1 `union` freeIn e2
188 freeIn (Extend e1 e2) = freeIn e1 `union` freeIn e2
189 freeIn (TupleExp es) = foldl union [] $ map freeIn es
190 freeIn (LitExp _) = []
191 freeIn (Ref v) = [v]
192 freeIn Self = [] -- hmm.
193 freeIn Super = [] -- hmm.
195 boundIn Discard = []
196 boundIn (LitPat _) = []
197 boundIn (Def v p) = [v] `union` boundIn p
198 boundIn (TuplePat ps) = foldl union [] $ map boundIn ps -- duplicates?
200 ---------------------------------------------------------------------------
201 -- Reader
203 tngDef = P.LanguageDef
204 { P.commentStart = "\""
205 , P.commentEnd = "\""
206 , P.commentLine = ""
207 , P.nestedComments = False
208 , P.identStart = letter
209 , P.identLetter = alphaNum
210 , P.opStart = (oneOf ":!#$%&*+./<=>?@\\^|-~")
211 , P.opLetter = (oneOf ":!#$%&*+./<=>?@\\^|-~" <|> alphaNum)
212 , P.reservedNames = ["self", "super"]
213 , P.reservedOpNames = []
214 , P.caseSensitive = True
215 }
217 tngTokenizer = P.makeTokenParser tngDef
219 reserved = P.reserved tngTokenizer
220 whiteSpace = P.whiteSpace tngTokenizer
221 ident = P.identifier tngTokenizer
222 natural = P.natural tngTokenizer
223 punct s = do string s; whiteSpace; return ()
224 operator = P.operator tngTokenizer
225 comma = P.comma tngTokenizer
227 mktup ctor [part] = part
228 mktup ctor parts = ctor parts
230 readExp = readExtend
231 readExtend = do (sub : supers) <- sepBy1 readTuple (punct "+"); return $ foldl Extend sub supers
232 readTuple = do parts <- sepBy1 readApp (punct ","); return $ mktup TupleExp parts
233 readApp = do (part : parts) <- sepBy1 readSimple whiteSpace; return $ foldl Send part parts
234 readSimple = do punct "("; e <- readExp; punct ")"; return e
235 <|> do punct "["; p <- readPat; punct "="; e <- readExp; punct "]"; return $ Clause p e
236 <|> do punct "."; i <- ident; return $ LitExp $ SymLit i
237 <|> do i <- natural; return $ LitExp $ IntLit i
238 <|> try (do reserved "self"; return Self)
239 <|> try (do reserved "super"; return Super)
240 <|> do i <- ident; return $ Ref i
242 readPat = do parts <- sepBy1 readSimplePat (punct ","); return $ mktup TuplePat parts
243 readSimplePat = do punct "("; p <- readPat; punct ")"; return p
244 <|> do punct "_"; return Discard
245 <|> do punct "."; i <- ident; return $ LitPat $ SymLit i
246 <|> do i <- natural; return $ LitPat $ IntLit i
247 <|> try (do i <- ident; punct "@"; p <- readSimplePat; return $ Def i p)
248 <|> do i <- ident; return $ Def i Discard
250 parseExpFromString = parse (do whiteSpace; v <- readExp; eof; return v) ""
252 read s = case parseExpFromString s of
253 Right v -> v
254 Left err -> error $ "Parse error: " ++ show err
256 ---------------------------------------------------------------------------
257 -- Writer
259 sepList t s [] = ""
260 sepList t s [x] = x ++ t
261 sepList t s (x:xs) = x ++ s ++ sepList t s xs
263 instance Show Exp where show v = showExp v
264 showExp (Clause p e) = "[" ++ show p ++ "=" ++ show e ++ "]"
265 showExp (Send e1 e2) = "(" ++ show e1 ++ " " ++ show e2 ++ ")"
266 showExp (Extend e1 e2) = "(" ++ show e1 ++ " + " ++ show e2 ++ ")"
267 showExp (TupleExp es) = "(" ++ sepList "" ", " (map showExp es) ++ ")"
268 showExp (LitExp l) = show l
269 showExp (Ref v) = v
270 showExp Self = "self"
271 showExp Super = "super"
273 instance Show Pat where show v = showPat v
274 showPat Discard = "_"
275 showPat (LitPat l) = show l
276 showPat (Def v Discard) = v
277 showPat (Def v p) = v ++ "@" ++ show p
278 showPat (TuplePat ps) = "(" ++ sepList "" ", " (map showPat ps) ++ ")"
280 instance Show Val where show v = showVal v
281 showVal (Closure clauses) = "[" ++ sepList "" ", " (map showClause clauses) ++ "]"
282 showVal (LitVal l) = show l
283 showVal (TupleVal vs) = "(" ++ sepList "" ", " (map showVal vs) ++ ")"
285 instance Show Literal where
286 show (SymLit s) = "." ++ s
287 show (IntLit i) = show i
289 showClause ([], p, e) = show p ++ "=" ++ show e
290 showClause (env, p, e) = sepList "::" ";" (Maybe.catMaybes $ map (showEnv e) env)
291 ++ show p ++ "=" ++ show e
293 showEnv exp (var, val) | var `elem` freeIn exp = Just $ var ++ "/" ++ show val
294 | otherwise = Nothing
296 ---------------------------------------------------------------------------
297 -- Driver
299 evalTop = eval [] empty empty
300 where empty = Closure []
302 readEval = evalTop . CoreETng.read
304 main = do putStr "> "
305 input <- getLine
306 putStrLn $ show $ readEval input
307 main