Life Goes On

まあまあだけど楽しんでる方です

続・Grass のインタプリタを書いてみたよ

という訳で、書き直しました。
Haskell による Grass のインタプリタです。Grass コードのファイル名を与えて実行します。
必要な仕様は、全て満たしているはず。全角文字(UTF-8Shift_JIS)も受け付けます。
バグ報告は随時お願いします。
Grass 人口が少しでも増えることを願って。

import Data.Char
import System.Environment
import Text.ParserCombinators.Parsec

data Instruction = App (Int,Int) | Abs (Int,[Instruction]) deriving Show
data Code = C [Instruction] | Out | Succ | Char Char | In deriving Show
data Function = F (Code,Environment) deriving Show
type Environment = [Function]
type Dump = Environment

e0 :: Environment
e0 = [F (Out,[]), F (Succ,[]), F (Char 'w',[]), F (In,[])]

d0 :: Dump
d0 = [F (C [App (1,1)], []), F (C [], [])]

eval :: (Code, Environment, Dump) -> IO ()
eval (C (App (m,n) : c), e, d) = eval (cm, F (cn,en) : em, F (C c,e) : d)
    where F (cm,em) = e !! (m-1)
          F (cn,en) = e !! (n-1)
eval (C (Abs (1,c') : c), e, d) = eval (C c, F (C c',e) : e, d)
eval (C (Abs (n,c') : c), e, d) = eval (C c, F (C [Abs (n-1,c')], e) : e, d)
eval (C [], f : e, F (c',e') : d) = eval (c', f : e', d)
eval (Out, f @ (F (Char c,_)) : e, d) = putChar c >> eval (C [], f : f : e, d)
eval (Out, F (c',f) : _, _) = error $ "Not a character: " ++ show c'
eval (In, e, d) = do {c <- getChar; eval (C [], F (Char c,[]) : e, d)}
    `catch` const (eval (C [], e, d))
eval (Succ, f @ (F (Char c,_)) : e, d) =
    eval (C [], F (Char $ chr $ mod (ord c + 1) 256,[]) : f : e, d)
eval (Succ, F (c',f) : _, _) = error $ "Not a character: " ++ show c'
eval (Char c0, f @ (F (Char c1,_)) : e, d) =
    eval (if c0 == c1 then C [Abs (1,[]), Abs (2,[App (3,2)])] else C [Abs (2,[])], f : e, d)
eval (Char _, e, d) = eval (C [Abs (2,[])], e, d)
eval (C [], _, []) = return ()

run :: Code -> IO ()
run c0 = eval (c0, e0, d0)

chars :: Char -> Parser Int
chars c = return . length =<< many1 (char c)

app :: Parser Instruction
app = do
    u <- chars 'W'
    l <- chars 'w'
    return $ App (u,l)

abst :: Parser Instruction
abst = do
    l <- chars 'w'
    a <- many app
    return $ Abs (l,a)

body :: Parser [Instruction]
body = try (char 'v' >> abst >>= return . (: []))
    <|> (char 'v' >> many app >>= return)

prog :: Parser [Instruction]
prog =  do
    a <- abst
    bs <- many body
    eof
    return $ a : concat bs

filter' :: String -> String
filter' [] = []
filter' ('W':s) = 'W' : filter' s
filter' ('v':s) = 'v' : filter' s
filter' ('w':s) = 'w' : filter' s
filter' ('\xef':'\xbc':'\xb7':s) = 'W' : filter' s
filter' ('\xef':'\xbd':'\x96':s) = 'v' : filter' s
filter' ('\xef':'\xbd':'\x97':s) = 'w' : filter' s
filter' ('\x82':'\x76':s) = 'W' : filter' s
filter' ('\x82':'\x96':s) = 'v' : filter' s
filter' ('\x82':'\x97':s) = 'w' : filter' s
filter' (_:s) = filter' s

parseProg :: String -> Code
parseProg s =
    case parse prog "" $ dropWhile (/= 'w') $ filter' s of
        Right i -> C i
        Left err -> error $ show err

main :: IO ()
main = run . parseProg =<< readFile . head =<< getArgs