git @ Cat's Eye Technologies Deturgenchry / a27f615
Make Continuation an ADT with `continue` op. Clearer? Shrug. catseye 9 years ago
1 changed file(s) with 38 addition(s) and 29 deletion(s). Raw diff Collapse all Expand all
+38
-29
src/Deturgenchry.hs less more
206206 | Obj Object
207207 | Objs [Object]
208208
209 type Continuation = ContObj -> ContObj
210
211 data ContJ = ContJ Continuation
212 instance Show ContJ where
213 show (ContJ _) = ""
214 instance Eq ContJ where
215 ContJ _ == ContJ _ = False
216
209 --
210 -- A continuation represents the remaining (sub-)computation(s) in a
211 -- computation.
212 --
213 data Continuation = Continuation (ContObj -> ContObj)
214
215 instance Show Continuation where
216 show (Continuation _) = ""
217 instance Eq Continuation where
218 Continuation _ == Continuation _ = False
219
220 continue (Continuation f) contObj =
221 f contObj -- straightforward enuff
222
223 --
224 -- An object is anything else. Including, maybe, a continuation.
225 --
217226 data Object = IntVal Integer
218227 | ObjVal String (Map Name Object)
219 | ContVal (Map Name Object) ContJ
228 | ContVal (Map Name Object) Continuation
220229 | Null
221230 deriving (Show, Eq)
222231
243252 Nothing -> error "No Main class with main() method found"
244253 Just mainMethod ->
245254 let
246 final = ContJ id
255 final = Continuation id
247256 r = callMethod p (ContVal EmptyMap final) mainMethod []
248257 in
249258 case r of
264273 case (length actuals) - (length formals) of
265274 0 ->
266275 let
267 self = (ContVal EmptyMap (ContJ id)) -- NO NOT REALLY
276 self = (ContVal EmptyMap (Continuation id)) -- NO NOT REALLY
268277 ctx = buildContext formals actuals
269278 ctx' = set "self" self ctx
270279 ctx'' = set "other" other ctx'
271280 in
272 evalStatement p ctx'' stmt id
281 evalStatement p ctx'' stmt (Continuation id)
273282 n | n > 0 ->
274283 error "Too many parameters passed to method"
275284 n | n < 0 ->
285294 evalStatement p ctx (Block []) cc =
286295 Ctx ctx
287296 evalStatement p ctx (Block (stmt:rest)) cc =
288 evalStatement p ctx stmt (\(Ctx ctx') ->
297 evalStatement p ctx stmt (Continuation $ \(Ctx ctx') ->
289298 evalStatement p ctx' (Block rest) cc)
290299
291300 evalStatement p ctx (Conditional e s1 s2) cc =
292 evalExpr p ctx e (\(Obj value) ->
301 evalExpr p ctx e (Continuation $ \(Obj value) ->
293302 case value of
294303 Null -> evalStatement p ctx s2 cc
295304 _ -> evalStatement p ctx s1 cc)
296305
297306 evalStatement p ctx (Transfer dest e) _ =
298 evalExpr p ctx e (\(Obj value) ->
299 evalExpr p ctx dest (\(Obj (ContVal m (ContJ k))) ->
307 evalExpr p ctx e (Continuation $ \(Obj value) ->
308 evalExpr p ctx dest (Continuation $ \(Obj (ContVal m (Continuation k))) ->
300309 k $ Obj value))
301310
302311 evalStatement p ctx (Assign name e) cc =
303 evalExpr p ctx e (\(Obj value) ->
312 evalExpr p ctx e (Continuation $ \(Obj value) ->
304313 case get name ctx of
305 Nothing -> cc $ Ctx $ set name value ctx
314 Nothing -> continue cc $ Ctx $ set name value ctx
306315 Just _ -> error ("Attempted re-assignment of bound name " ++ name))
307316
308317 ---------------------------------------------------
311320 evalExpr p ctx (Get [name]) cc =
312321 case get name ctx of
313322 Nothing -> error ("Name " ++ name ++ " not in scope")
314 Just val -> cc $ Obj val
323 Just val -> continue cc $ Obj val
315324 evalExpr p ctx (Get (name:names)) cc =
316 evalExpr p ctx (Get names) (\(Obj value) ->
317 cc $ Obj $ getAttribute name value)
325 evalExpr p ctx (Get names) (Continuation $ \(Obj value) ->
326 continue cc $ Obj $ getAttribute name value)
318327
319328 evalExpr p ctx (Call [localName, methodName] exprs) cc =
320 evalExprs p ctx exprs [] (\(Objs actuals) ->
321 evalExpr p ctx (Get [localName]) (\(Obj (ObjVal className attrs)) ->
329 evalExprs p ctx exprs [] (Continuation $ \(Objs actuals) ->
330 evalExpr p ctx (Get [localName]) (Continuation $ \(Obj (ObjVal className attrs)) ->
322331 let
323332 Just klass = getClass className p
324333 Just method = getMethod methodName klass
325 newOther = ContVal ctx $ ContJ cc
334 newOther = ContVal ctx $ cc
326335 in
327336 callMethod p newOther method actuals))
328337
329338 evalExpr p ctx (Mod names pairs) cc =
330 cc $ Obj Null
339 continue cc $ Obj Null
331340
332341 evalExpr p ctx (IntLit i) cc =
333 cc $ Obj $ IntVal (evalIntLit i)
342 continue cc $ Obj $ IntVal (evalIntLit i)
334343
335344 evalExpr p ctx (New className) cc =
336 cc $ Obj $ ObjVal className EmptyMap
345 continue cc $ Obj $ ObjVal className EmptyMap
337346
338347 ---------------------------------------------------
339348
340349 evalExprs p ctx [] vals cc =
341 cc $ Objs vals
350 continue cc $ Objs vals
342351
343352 evalExprs p ctx (expr:exprs) vals cc =
344 evalExpr p ctx expr (\(Obj val) ->
353 evalExpr p ctx expr (Continuation $ \(Obj val) ->
345354 evalExprs p ctx exprs (val:vals) cc)
346355
347356 ---------------------------------------------------