Lispインタプリタ(2)
でーきーたー。
Main >run "(begin (define fact (lambda(x) (if (= x 0) 1 (* x (fact (- x 1)))))) (fact 10))" 3628800
複数の式の評価には、また対応していないけれど、ちゃんと階乗も計算できる。
で、
lispEq (x:y:[]) env = let (x',env') = eval x env in let (y',env'') = eval y env' in (Bool (x' == y'),env'')
とかから、Stateモナドを使うべきにおいがプンプンしてるのであとで書き直そう。
import Text.ParserCombinators.Parsec import Control.Monad import Control.Monad.State -- data type data LispVal = Int Int -- 0,1,2,... | String String -- "hoge" | Char Char -- #\a,#\b | Bool Bool -- #t,#f | Symbol String -- hoge | List [LispVal] -- (+ 1 2 3) | Proc ([LispVal]->Env->(LispVal,Env)) -- procedure | IOVal (IO ()) -- IO | Undef type Env = [(String,LispVal)] instance Eq LispVal where (Int m) == (Int n) = m == n (String s) == (String t) = s == t (Char c) == (Char d) = c == d (Bool b) == (Bool b') = b == b' (Symbol s) == (Symbol t) = s == t (List x) == (List y) = and $ zipWith (==) x y _ == _ = False instance Show LispVal where show (Int n) = show n show (String s) = show s show (Char c) = "#\\" ++ show c show (Bool b) = if b then "#t" else "#f" show (Symbol s) = s show (List x) = show $ map show x show (Proc _) = "#<proc>" show (IOVal _) = "#<io>" show Undef = "#<undef>" -- parser symbol = oneOf "!$#%&|*+-/:<=>?@^_~" pSymbol = do x <- letter <|> symbol xs <- many $ letter <|> digit <|> symbol return $ Symbol (x:xs) pInt = do x <- many1 digit return $ Int $ read x pBool = do char '#' c <- oneOf "tf" return $ Bool (c=='t') pChar = do string "#\\" c <- letter return $ Char c -- liftM?? pNil = do string "()" return $ List [] -- liftM?? pList = do char '(' exps <- pExpr `sepBy1` spaces char ')' return $ List exps pMain = do x <- pExpr eof return x pExpr = pString <|> try pBool <|> try pChar <|> pSymbol <|> pInt <|> try pNil <|> pList pString = do char '"' x <- many $ noneOf "\"" char '"' return $ String x readExpr :: String -> LispVal readExpr s = case parse pMain "lisp" s of Left err -> String $ show err Right val -> val -- eval ---- ugly evalList::[LispVal]->Env->([LispVal],Env) evalList xs env = let (xs',env') = evalList' xs env in (reverse xs',env') where f (xs,env) val = let (x,env') = eval val env in (x:xs,env') evalList' xs env = foldl f ([],env) xs eval :: LispVal -> Env-> (LispVal,Env) trueCheck (Bool False) = False trueCheck (List []) = False trueCheck _ = True stub = (Int 0,[]) eval (List ((Symbol "if"):cond:cthen:celse:[])) env = let (val,env') = eval cond env in if trueCheck val then eval cthen env' else eval celse env' eval (List ((Symbol "define"):(Symbol name):exps)) env = let (val,env') = evalList exps env in (Undef,(name,last val):env') eval (List ((Symbol "lambda"):(List names):exps)) env = (Proc $ (\args env'-> let env'' = concat [zip (string names) args,env',env] in let (v,env''') = evalList exps env'' in (last v,env''')),env) where string = map (\(Symbol x)->x) eval (List ((Symbol "begin"):exps)) env = let (val,env') = evalList exps env in (last val,env') eval (List xs) env = let (op:args,env') = 0evalList xs env in case op of Proc f -> f args env' x -> error $ show x eval (Symbol name) env = case lookup name env of Just proc -> (proc,env) Nothing -> error $ "symbol undefined:" ++ name eval x env = (x,env) -- procedure mathOp op = Proc (\args env->(foldl1 f args,env)) where (Int x) `f` (Int y) = Int $ x `op` y _ `f` _ = error "type missmatch" lispPlus = mathOp (+) lispMinus = mathOp (-) lispMul = mathOp (*) lispDiv = mathOp div lispEq (x:y:[]) env = let (x',env') = eval x env in let (y',env'') = eval y env' in (Bool (x' == y'),env'') defaultEnv = [("+",lispPlus),("-",lispMinus),("*",lispMul),("/",lispDiv),("=",Proc lispEq)] -- main run s= fst $ eval (readExpr s) defaultEnv -- test sample = "(+ 1 2)" result = run sample