module Cont where { import ContType; import ContParser; {---------------------------------------------------------------------- インタプリタ ----------------------------------------------------------------------} type Env = [(String, Value)] ; lookupM :: String -> Env -> M Value; lookupM x ((n,v):rest) = if n==x then unitM v else lookupM x rest; lookupM x [] = failM ("Variable: "++x++" is not found"); interpLabeledExpr :: LabeledExpr -> Env -> (Env, Value -> Result) -> (Env, Value -> Result); interpLabeledExpr (Just id, e) env (xs, c2) = let { c1 = \ _ -> interp e env c2 } in ((id, Cont c1):xs, c1); interpLabeledExpr (Nothing, e) env (xs, c2) = let { c1 = \ _ -> interp e env c2 } in (xs, c1); interpLabeledExprSeq :: [LabeledExpr] -> Env -> (Value -> Result) -> (Env, Value -> Result); interpLabeledExprSeq les env c = foldr (\ le (e, k) -> interpLabeledExpr le env (e, k)) ([], c) les; interp :: Expr -> Env -> M Value; interp (Const c) e = unitM c; interp (Var x) e = lookupM x e; interp (Let (x, m) n) e = interp m e `bindM` \ v -> interp n ((x,v):e); {- -- Continuationのmonadでmfixは定義できない -- cf. Recursive Monadic Bindings -- by Levent Erk\"ok and John Launchbury interp (Letrec (x, m) n) e = mfix (\ v -> interp m ((x,v):e)) `bindM` \ v -> interp n ((x,v):e); -- 代わりに関数の再帰のみ許すmfixUを使用する -} interp (Letrec (x, m) n) e = mfixU (\ v -> interp m ((x, Fun v):e) `bindM` \ v1 -> case v1 of { Fun f -> unitM f; _ -> failM ("function expected:" ++ showValue v1 ++ ":.") }) `bindM` \ v -> interp n ((x, Fun v):e); interp (App f x) e = interp f e `bindM` \ g -> case g of { Fun h -> interp x e `bindM` \ y -> h y; v -> failM ("App: Function expected:"++ showValue v ++":.") }; interp (Lambda x m) e = unitM (Fun (\ v -> interp m ((x,v):e))); interp (If e1 e2 e3) e = interp e1 e `bindM` \ v -> case v of { Bool b -> if b then interp e2 e else interp e3 e; _ -> failM "Boolean expected" }; interp (SetX e1) e = interp e1 e `bindM` \ v -> setX v; interp (SetY e1) e = interp e1 e `bindM` \ v -> setY v; interp (SetZ e1) e = interp e1 e `bindM` \ v -> setZ v; interp GetX e = getX; interp GetY e = getY; interp GetZ e = getZ; interp (Begin les) e = \ c -> let { (e', c1) = interpLabeledExprSeq les (e'++e) c } in c1 Unit; {- interp (Begin es) e = case es of { [(_, f)] -> interp f e; (_, f):fs -> interp f e `bindM` \ _ -> interp (Begin fs) e }; -} interp (While e1 e2) e = \ c1 -> let { env1 = ("break", Cont c1) : e } in interp e1 e (\ v -> case v of { Bool b -> if b then let { c2 = \ _ -> interp (While e1 e2) e c1 } in let { env2 = ("continue", Cont c2) : env1 } in interp e2 env2 c2 else c1 (Bool True); _ -> failM "Boolean expected" c1 }); interp Break e = \ c0 -> lookupM "break" e (\ (Cont c) -> c (Bool False)); interp Continue e = \ c0 -> lookupM "continue" e (\ (Cont c) -> c (Bool False)); interp Abort e = abortM (\ s -> s); {- interp (Callcc e) = \ env c0 -> interp e env (\ x -> case x of Fun f -> f (Fun (\ v env1 c1 -> c0 v)) env c0 _ -> failM ("Callcc: Function expected") env c0); -} interp (Callcc e1) e = interp e1 e `bindM` \ x -> case x of { Fun f -> callccM (\ k -> f (Fun k)); _ -> failM ("Callcc: Function expected") }; interp (Goto label) e = \ c0 -> lookupM label e (\ (Cont c) -> c (Bool False)); binop op = Fun (\ v -> case v of { Num c -> unitM (Fun (\ w -> case w of { Num d -> unitM (Num (op c d)); _ -> failM "Number expected" })); _ -> failM "Number expected" }); binop2 op = Fun (\ v -> case v of { Num c -> unitM (Fun (\ w -> case w of { Num d -> unitM (Bool (op c d)); _ -> failM "Number expected" })); _ -> failM "Number expected" }); divop = Fun (\ v -> case v of { Num c -> unitM (Fun (\ w -> case w of { Num 0 -> failM "Division by 0"; Num d -> unitM (Num (c/d)); _ -> failM "Number expected" })); _ -> failM "Number expected" }); myPair = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Pair v1 v2)))); myFst = Fun (\ v -> case v of { Pair v1 v2 -> unitM v1; _ -> failM "Pair expected" }); mySnd = Fun (\ v -> case v of { Pair v1 v2 -> unitM v2; _ -> failM "Pair expected" }); myTriple = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Fun (\ v3 -> unitM (Pair v1 (Pair v2 v3))))))); myFst3 = Fun (\ v -> case v of { Pair v1 v2 -> unitM v1; _ -> failM "Triple expected" }); mySnd3 = Fun (\ v -> case v of { Pair v1 (Pair v2 _) -> unitM v2; _ -> failM "Triple expected" }); myThd3 = Fun (\ v -> case v of { Pair v1 (Pair v2 v3) -> unitM v3; _ -> failM "Triple expected" }); myToString = Fun (\ v -> unitM (Str (showValue v))); myStrAppend = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Str (showValue v1 ++ showValue v2))))); myIsPair = Fun (\ v -> case v of { Pair _ _ -> unitM (Bool True); _ -> unitM (Bool False) }); myIsUnit = Fun (\ v -> case v of { Unit -> unitM (Bool True); _ -> unitM (Bool False) }); initEnv = [("+", binop (+)), ("-", binop (-)), ("*", binop (*)), ("/", divop), ("%", binop (\ x y -> fromInteger (round x `rem` round y))), ("not", Fun (\ (Bool b) -> unitM (Bool (not b)))), ("==", binop2 (==)), ("/=", binop2 (/=)), (">", binop2 (>)), (">=", binop2 (>=)), ("<", binop2 (<)), ("<=", binop2 (<=)), ("True", Bool True), ("False", Bool False), ("Unit", Unit), ("isUnit", myIsUnit), ("pair", myPair), ("fst", myFst), ("snd", mySnd), ("cons", myPair), ("car", myFst), ("cdr", mySnd), ("nil", Unit), ("isPair", myIsPair), ("isCons", myIsPair), ("triple", myTriple), ("fst3", myFst3), ("snd3", mySnd3), ("thd3", myThd3), ("++", myStrAppend), ("toString", myToString) ]; fst3 :: (a, b, c) -> a; fst3 (a, b, c) = a; run :: String -> String; run str = showValue (fst3 (interp (myParse str) initEnv (\ v (_, y, z) -> (v, y, z)) (Unit, Unit, Unit))); main :: IO (); main = interact run; load :: String -> IO (); load path = readFile path >>= \ prog -> putStrLn (run prog); load0 :: String -> IO (); load0 path = readFile path >>= \ prog -> putStr (show (myParse prog)); -- for example, {- run ("let fact = \\ n -> "++ " begin "++ " setX 1; setY n; "++ " while getY > 0 do begin "++ " let r = getX in "++ " let n = get inY "++ " setX (r*n); setY (n-1); "++ " end; "++ " getX; "++ " end in "++ "setX (fact 9)") -} }