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