Brainfuck Intepreter

bf.hs

{-# OPTIONS_GHC -O2 -optc-O2 #-}
import Control.Monad
import Text.ParserCombinators.Parsec
import Control.Monad.State
import Data.Array.IO
import Data.Char
import Debug.Trace

data Stmt = INCPNT | DECPNT | INC | DEC | OUTPUT | READ
          | Loop [Stmt] 
          deriving Show

stmt = (char '>' >> return INCPNT)
   <|> (char '<' >> return DECPNT)
   <|> (char '+' >> return INC)
   <|> (char '-' >> return DEC)
   <|> (char '.' >> return OUTPUT)
   <|> (char ',' >> return READ)
   <|> do char '['
          sts <- many stmt
          char ']'
          return . Loop $ sts

parseBF :: String -> Either ParseError [Stmt]
parseBF = parse (many stmt) "bf"

type EnvState a = StateT (IOArray Int Int, Int) IO a
memlimit = 30000

eval :: Stmt -> EnvState ()
eval INCPNT = do (arr, pnt) <- get
                 let pnt' = if pnt == memlimit then 0 else pnt + 1
                 put (arr, pnt')

eval DECPNT = do (arr, pnt) <- get
                 let pnt' = if pnt == 0 then memlimit else pnt - 1
                 put (arr, pnt')

eval INC = do (arr, pnt) <- get
              v <- liftIO $ readArray arr pnt
              let v' = if v == 255 then 0 else v + 1
              liftIO $ writeArray arr pnt v'
              put (arr, pnt)

eval DEC = do (arr, pnt) <- get
              v <- liftIO $ readArray arr pnt
              let v' = if v == 0 then 255 else v - 1
              liftIO $ writeArray arr pnt v'
              put (arr, pnt)

eval OUTPUT = do (arr, pnt) <- get
                 v <- liftIO $ readArray arr pnt
                 liftIO . putChar . chr $ v
                 put (arr, pnt)

eval READ = do (arr, pnt) <- get
               c <- liftIO getChar
               liftIO $ writeArray arr pnt $ ord c
               put (arr, pnt)

eval (Loop sts) = do (arr, pnt) <- get
                     v <- liftIO $ readArray arr pnt
                     when (v /= 0) $ mapM_ eval sts

                     (arr', pnt') <- get
                     v' <- liftIO $ readArray arr' pnt'
                     when (v' /= 0) $ eval (Loop sts)

evalBF = mapM_ eval

main = do
        text <- getContents
        case parseBF (filter (`elem` "><+-.,[]") text) of
            Left err -> print err
            Right sts -> do
                   arr <- newArray (0, memlimit) 0
                   execStateT (evalBF sts) (arr, 0)
                   return ()