Lispインタプリタ - みずぴー日記

まだ、S式計算機という程度。30分で作ったわけじゃないけど、とりあえず、今日はこれで。

とこで、

pInt = do x <- many1 digit
          return $ Int $ read x

や

pNil = do string "()"
          return $ List [] -- liftM??

はもっとエレガントに書ける気がするのだけれど、分からない。

import Text.ParserCombinators.Parsec
import Control.Monad

-- 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) -- procedure

type Env = [(String,LispVal)]

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>"

-- 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
eval :: LispVal -> Env-> (LispVal,[IO ()])
eval (List xs) env = let (Proc op,_):args = map ((flip eval) env) xs in
                     (op (map fst args) env,[])
eval (Symbol name) env = case lookup name env of
                           Just proc -> (proc,[])
                           Nothing -> error "symbol undefined"
eval x _ = (x,[])


-- procedure
mathOp op = Proc (\args _->foldl1 f args)
    where (Int x) `f` (Int y)  = Int $ x `op` y
          _ `f` _ = error "type missmatch"

lispPlus = mathOp (+)
lispMinus = mathOp (-)
lispMul = mathOp (*)
lispDiv = mathOp div

defaultEnv = [("+",lispPlus),("-",lispMinus),("*",lispMul),("/",lispDiv)]

-- main
run s= fst $ eval (readExpr s) defaultEnv
-- test
sample = "(+ 1 2)"
result = run sample

evalはmapじゃ絶対にダメだろうなぁ
あとdefineとlambdaは欲しいな