Haskell で lisp とか実装してみる(まだ動かない)

LISP.hs

module LISP where

import Text.ParserCombinators.Parsec
import Control.Monad.State

data Value = Sym Identifier
           | Int Int
           | Str String
           | List [Value]
           | Closure [Identifier] Expr Env
           deriving (Show, Eq)

data Acc  = Acc Value
           deriving (Show, Eq)

data Expr  = HaltExpr
           | ConstExpr Value Expr
           | PrintExpr Expr
           | ReferExpr Identifier Expr
           | AssignExpr Identifier Expr
           | CloseExpr [Identifier] Expr Expr
           | FrameExpr Expr Expr 
           | ArgExpr Expr
           | ApplyExpr
           | ReturnExpr
           deriving (Show, Eq)

type Env   = [Var]
type Rib   = [Value]
data Stack = EmptyStack
           | Stack (Expr, Env, Rib, Stack)
           deriving (Show)

type Var   = (Identifier, Value)
type Identifier = String

data VM = VM Acc Expr Env Rib Stack deriving (Show)

nil :: Value
nil = List []

parseProgram :: Parser Value
parseProgram = many list >>= return . List
             where list = do
                     l <- parseList
                     skipSpaces
                     return l
                   skipSpaces = skipMany (oneOf " \t\n")

parseList :: Parser Value
parseList = do
    l <- between (char '(') (char ')') (many elem)
    return $ List l
    where elem = do
            elem <- parseElem
            skipSpaces
            return elem
          skipSpaces = skipMany (oneOf " \t\n")

parseElem :: Parser Value
parseElem = try parseSym <|> try parseInt <|> try parseStr <|> parseList <?> "a value"

parseSym = do
    id <- symbol
    return $ Sym id
    where symbol = do
            a <- beginLetter
            b <- many containLetter
            return (a:b)
          beginLetter = letter
          containLetter = letter <|> oneOf "0123456789" <|> oneOf "-"

parseStr = do
    str <- string_
    return $ Str str
    where string_ = between (char '"')
                            (char '"')
                            (many (do{ string "\\\""; return '"' } <|> noneOf ['"']))

parseInt = do
    int <- integer
    return $ Int int
    where integer = do { s <- many1 $ oneOf "0123456789"; return $ read s }

compile :: Value -> Expr -> Expr
compile (Sym a) end = ReferExpr a end        
compile (List []) end = end

compile (List ((Sym "print"):args)) end = (compileList args) $ PrintExpr end
compile (List ((Sym "setq"):(Sym v):x:[])) end = (compile x) $ AssignExpr v end
compile (List ((Sym "lambda"):(List vars):body:[])) end =
        CloseExpr (toIds vars) (compile body ReturnExpr) end
        where toIds :: [Value] -> [Identifier]
              toIds vars = 
                case vars of
                  (Sym v):[] -> [v]
                  (Sym v):vs -> v:toIds vs
compile (List (x:xs)) ret =
        recur xs (compile x ApplyExpr)
        where recur [] c = FrameExpr ret c
              recur (arg:args) c = recur args (compile arg (ArgExpr c))

-- compile (List list) end = ConstExpr (List list) end
compile val end = ConstExpr val end

compileProgn (List (x:xs)) end = (compile x) $ ((compileProgn $ List xs) end)
compileProgn (List []) end = end

compileList [] end = end
compileList (x:xs) end = compile x $ compileList xs end

vm :: StateT VM IO ()
vm = do
   state <- get
   case state of
     (VM a HaltExpr e r s)                    -> return ()
     (VM a (ConstExpr x nxt) e r s)           -> do
       put (VM (Acc x) nxt e r s)
       vm
     (VM (Acc a) (PrintExpr nxt) e r s)       -> do
       liftIO $ putStrLn $ toString a
       put (VM (Acc a) nxt e r s)
       vm
     (VM a (ReferExpr id nxt) e r s)          -> do
       put (VM ((Acc . snd) $ LISP.lookup id e) nxt e r s)
       vm
     (VM (Acc a) (AssignExpr id nxt) e r s)   -> do
       put (VM ((Acc . snd) $ (LISP.lookup id e)) nxt (assign id a e) r s)
       vm
     (VM a (FrameExpr ret nxt) e r s)         -> do
       put (VM a nxt e [] (callFrame (ret, e, r, s)))
       vm
     (VM (Acc a) (ArgExpr nxt) e r s)                     -> do
       put (VM (Acc a) nxt e (a:r) s)
       vm
     (VM (Acc (Closure vars body ce)) ApplyExpr e r s) -> do
       put (VM (Acc (Closure vars body ce)) body (extend ce vars r) [] s)
       vm
     (VM a ReturnExpr _ _ (Stack (x, e, r, s)))    -> do
       put (VM a x e r s)
       vm
     (VM a ReturnExpr _ _ EmptyStack)         -> do
       liftIO $ putStrLn "warning: stack is empty."
       vm
     (VM a (CloseExpr vars body nxt) e r s)   -> do
       put (VM (Acc $ Closure vars body e) nxt e r s)
       vm

callFrame :: (Expr, Env, Rib, Stack) -> Stack
callFrame (x, e, r, s) = Stack (x, e, r, s)

extend :: Env -> [Identifier] -> Rib -> Env
extend e [] [] = e
extend e (var:vars) [] = (var, nil) : extend e vars []
extend e (var:vars) (val:vals) = (var, val) : extend e vars vals

assign :: Identifier -> Value -> Env -> Env
assign id v [] = [(id, v)]
assign id v ((vid, val) : e) | id == vid = (id, v) : e
                             | otherwise = (vid, val) : assign id v e

lookup :: Identifier -> Env -> Var
lookup id [] = error "lookup failed"
lookup id ((vid, val):e) | id == vid = (vid, val)
                         | otherwise = LISP.lookup id e

toString :: Value -> String
toString (Sym a) = "'" ++ a
toString (Int x) = show x
toString (Str s) = s
toString (List []) = "(nil)"
toString (List (x:[])) = toString x
toString (List (x:xs)) = toString x ++ (toString $ List xs)
toString (Closure vars body e) =
         concat [ "lambda", "(", unwords vars, ")"
                , " -> ", "{ ", show body, " }"
                , " in ", show e, ";"]

main = do
    evalStateT vm (VM (Acc (Str "hello")) (PrintExpr HaltExpr) [("a", (Int 1))] [] EmptyStack)
    evalStateT vm (VM (Acc (Str "hello")) (ReferExpr "a" $ PrintExpr HaltExpr) [("a", (Int 1))] [] EmptyStack)
    evalStateT vm (VM (Acc (Str "hello")) (AssignExpr "a" $ ReferExpr "a" $ PrintExpr HaltExpr) [("a", (Int 1))] [] EmptyStack)
    -- "(print \"hello world\") (print 1) (setq a (lambda (x y) (a))) (print a) (print (a))"
    case parse parseProgram "(fname.lisp)" "(print \"hello world\") (print 1) (setq a (lambda (x y) x)) (print a) (print (a 5)) (setq b (lambda (x) (lambda (y) (print x)))) ((b 1) 2)" of
      Right val -> do
        print $ compileProgn val $ HaltExpr
        evalStateT vm (VM (Acc (List [])) (compileProgn val HaltExpr) [] [] EmptyStack)
      Left err -> do
        putStr "parse error at"
        print err