{---------------------------------------------------------------------- インタプリタ * LetRec + オブジェクト指向の導入 ・f x y z = ... のような関数定義を可能にする ・メソッド名は、アンダースコア（_）で始まる ・クラス名は、アルファベットの大文字で始まる ・メソッドの定義は環境とは別の辞書（テーブル）に入れる ・辞書は State Readerで受け渡す。 ・クラス定義の例 ColorPoint x y c = Point x y ・メソッド定義の例 _move this@(Point x y) = Point (x+10) y 参考 Structure and Interpretation of Computer Programs J. J. Sussman, H. Abelson J. Sussman （邦訳: 計算機プログラムの構造と解釈 和田 英一 訳） Expr -> Expr || Expr | Expr && Expr | Expr == Expr | Expr /= Expr | Expr < Expr | Expr <= Expr | Expr >= Expr | Expr > Expr | Expr ++ Expr --- 文字列の連接 | Expr * Expr | Expr / Expr | Expr + Expr | Expr - Expr | Expr Expr | Const | ( Expr ) | Ident | let DeclSeq Expr | letrec DeclSeq Expr | fn Ident -> Expr | if Expr then Expr else Expr PatSeq -> = | Ident PatSeq Decl -> Ident PatSeq Expr DeclSeq -> Decl in | Decl; DeclSeq IdentSeq -> ) | Ident IdentSeq CPat -> Ident | ( Ident IdentSeq ExtPat -> Ident | Ident @ CPat | CPat ExtPatSeq -> = | ExtPat ExtPatSeq MethodDecl -> Ident ExtPatSeq Expr MethodDeclSeq -> MethodDecl in | MethodDecl; MethodDeclSeq GlobalDecl -> let DeclSeq GlobalDecl | letrec DeclSeq GlobalDecl | class DeclSeq GlobalDecl | method MethodDeclSeq GlobalDecl | Expr ----------------------------------------------------------------------} module OOP where { import OOPType; import OOPParser; type Env = [(String, Value)]; lookup' :: Eq a => a -> [(a, b)] -> b; lookup' x ((n,v):rest) = if n==x then v else lookup' x rest; {-- -- Preludeの lookupと全く同じ lookup :: Eq a => a -> [(a, b)] -> Maybe b; lookup k [] = Nothing; lookup k ((x,y):xys) = if k==x then Just y else lookup k xys; --} applyMethod :: String -> Value -> Value -> Env -> M Value; applyMethod m self (obj@(ObjectV c args)) e dic = case lookup (m, c) dic of { Nothing -> let { Just super = lookup ("__super", c) dic } in interp (App (App (Const super) (Const self)) (Const obj)) e dic `bindId` \ obj1 -> applyMethod m self obj1 e dic; Just f -> interp (App (App (Const f) (Const self)) (Const obj)) e dic }; applyMethod m self _ e dic = error ("Method "++m++" is applied to non-object."); interpDecl ((id, ps), m) e = let { m1 = foldr (\ a b -> Lambda a b) m ps } in interp m1 e `bindM` \ v -> unitM (id, v); interpDecls [] e = unitM []; interpDecls (d:ds) e = interpDecl d e `bindM` \ (id, v) -> interpDecls ds e `bindM` \ rest -> unitM ((id, v):rest); interp :: Expr -> Env -> M Value; interp (Const c) e = unitM c; interp (Var x) e = unitM (lookup' x e); interp (Let decl n) e = interpDecl decl e `bindM` \ d -> interp n (d : e); interp (Letrec ((x, ps), m) n) e = mfixU (\ v -> let { m1 = foldr (\ a b -> Lambda a b) m ps } in interp m1 ((x, Fun v):e) `bindM` \ v1 -> case v1 of { Fun f -> unitM f; _ -> unitM (\ _ -> failM "function expected") {- 本物の failMではないので failM "function expected" では型があわない -} }) `bindM` \ v -> interp n ((x, Fun v):e); interp (App f x) e = interp f e `bindM` \ v -> case v of { Fun g -> interp x e `bindM` \ y -> g y; MethodV m -> interp x e `bindM` \ y -> applyMethod m y y e; _ -> failM "Function expected"; }; interp (Lambda x m) e = unitM (Fun (\ v -> interp m ((x,v) : e))); interp (If e1 e2 e3) e = interp e1 e `bindM` \ (Bool b) -> if b then interp e2 e else interp e3 e; interpClassDecl :: Decl -> Env -> Dict -> Id (Env, Dict); interpClassDecl ((id, args), rhs) e0 d0 = let { loop [] vs = ObjectV id (reverse vs); loop (x:xs) vs = Fun (\ v -> unitM (loop xs (v:vs))); constr = loop args []; super = Fun (\ self -> unitM (Fun (\ (ObjectV _ ys) -> let { alist = zip args ys } in interp rhs (alist ++ e0)))) } in unitId ((id, constr) : e0, (("__super", id), super):d0); interpClassDecls :: [Decl] -> Env -> Dict -> Id (Env, Dict); interpClassDecls (decl:decls) e0 d0 = interpClassDecl decl e0 d0 `bindId` \ (e1, d1) -> interpClassDecls decls e1 d1; interpClassDecls [] e0 d0 = unitId (e0, d0); newMethodId id e0 = case lookup id e0 of { Just (MethodV _) -> e0; _ -> (id, MethodV id) : e0 }; interpMethodDecl :: MethodDecl -> Env -> Dict -> Id (Env, Dict); interpMethodDecl ((id, [pat]), rhs) e0 d0 = let { m = Fun (\ self -> unitM (Fun (\ (ObjectV _ args) -> let { alist = case pat of { SimplePat x -> [(x, self)]; AsPat x (c, ps) -> (x, self) : zip ps args; ConsPat (c, ps) -> zip ps args } } in interp rhs (alist ++ e0)))); c = case pat of { SimplePat _ -> "Unit"; AsPat _ (c, _) -> c; ConsPat (c, _) -> c }; } in unitId (newMethodId id e0, ((id, c), m):d0); interpMethodDecls :: [MethodDecl] -> Env -> Dict -> Id (Env, Dict); interpMethodDecls (decl:decls) e0 d0 = interpMethodDecl decl e0 d0 `bindId` \ (e1, d1) -> interpMethodDecls decls e1 d1; interpMethodDecls [] e0 d0 = unitId (e0, d0); interpGlobal :: Global -> Env -> M Value; interpGlobal (LetG decl n) e = interpDecl decl e `bindM` \ d -> interpGlobal n (d:e); interpGlobal (LetrecG ((x, ps), m) n) e = mfixU (\ v -> let { m1 = foldr (\ a b -> Lambda a b) m ps } in interp m1 ((x, Fun v):e) `bindM` \ v1 -> case v1 of { Fun f -> unitM f; _ -> unitM (\ _ -> failM "function expected") {- 本物の failMではないので failM "function expected" では型があわない -} }) `bindM` \ v -> interpGlobal n ((x, Fun v):e); interpGlobal (ClassG decls n) e = \ dic -> interpClassDecls decls e dic `bindId` \ (e1, d1) -> interpGlobal n e1 d1; interpGlobal (MethodG decls n) e = \ dic -> interpMethodDecls decls e dic `bindId` \ (e1, d1) -> interpGlobal n e1 d1; interpGlobal (ExprG exp) e = interp exp e; binop op = Fun (\ (Num c) -> unitM (Fun (\ (Num d) -> unitM (Num (op c d))))); binop2 op = Fun (\ (Num c) -> unitM (Fun (\ (Num d) -> unitM (Bool (op c d))))); myPair = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Pair v1 v2)))); myFst = Fun (\ (Pair v1 v2) -> unitM v1); mySnd = Fun (\ (Pair v1 v2) -> unitM v2); myIsPair = Fun (\ v -> case v of { Pair _ _ -> unitM (Bool True); _ -> unitM (Bool False) }); myIsUnit = Fun (\ v -> case v of { ObjectV "Unit" _ -> unitM (Bool True); _ -> unitM (Bool False) }); unit = ObjectV "Unit" []; myToString = Fun (\ v -> unitM (Str (showValue v))); myStrAppend = Fun (\ v1 -> unitM (Fun (\ v2 -> unitM (Str (showValue v1 ++ showValue v2))))); initEnv = [("+", binop (+)), ("-", binop (-)), ("*", binop (*)), ("/", binop (/)), ("%", 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), ("pair", myPair), ("isPair", myIsPair), ("Unit", unit), ("isUnit", myIsUnit), ("fst", myFst), ("snd", mySnd), ("++", myStrAppend), ("toString", myToString) ]; initDict :: Dict; initDict = []; run :: String -> String; run str = showValue (interpGlobal (myParse str) initEnv initDict); main :: IO (); main = interact run; load :: String -> IO (); load path = readFile path >>= \ prog -> putStrLn (run prog); -- for example, -- load "OOP.utl" }