Brainfuck Interpreter

brainfuck.hs

import Control.Applicative ((<$>))
import Control.Monad       (liftM2)
import Data.Char           (chr, ord)
import Data.List           (group)
import System.Environment  (getArgs)
import Text.Parsec
import Text.Parsec.String

data Inst = Inc | Dec | R | L | In | Out
    deriving Show

data CodeTree = Leaf Inst CodeTree
              | Loop CodeTree CodeTree
              | Code CodeTree
              | Nil
              | Err String
              deriving Show

data InstPtr = ToLoop   CodeTree -- go left
             | FromLoop CodeTree -- go right
             | ReadNext CodeTree -- go straight
             | Start
               deriving Show

type InstPtrs   = [InstPtr]
type CodeZipper = (InstPtrs, CodeTree)
type Memory     = [Int]
type MemZipper  = (Memory, Memory) 

runBFParser :: Parser CodeTree -> String -> CodeTree
runBFParser p input = case parse p "" input of
    Left  err -> Err $ show err
    Right val -> Code val

parseBF :: Parser CodeTree
parseBF = foldr1 apply <$> many1 parsers
    where parsers = loopP <|> incP <|> decP <|> rP <|> lP <|> inpP <|> oupP
          loopP = liftM2 Loop (between (char '[') (char ']') parseBF) parseBF 
          incP  = char '+' >> return (Leaf Inc Nil)
          decP  = char '-' >> return (Leaf Dec Nil)
          rP    = char '>' >> return (Leaf R   Nil)
          lP    = char '<' >> return (Leaf L   Nil)
          inpP  = char ',' >> return (Leaf In  Nil)
          oupP  = char '.' >> return (Leaf Out Nil)

apply (Leaf i Nil) y = Leaf i y
apply _            _ = Nil

run code = eval ([], code) ([],[0,0..])

eval :: CodeZipper -> MemZipper -> IO ()
eval codeZipper memZipper = do
    let (ptrs , tree) = codeZipper
    case tree of
        (Code x)     -> eval (Start                    :ptrs, x) (front, back)
        (Loop x   y) -> eval ((ToLoop y)               :ptrs, x) (front, back)
        (Leaf Inc x) -> eval ((ReadNext $ Leaf Inc Nil):ptrs, x) (front, incHead back)
        (Leaf Dec x) -> eval ((ReadNext $ Leaf Dec Nil):ptrs, x) (front, decHead back)
        (Leaf R   x) -> eval ((ReadNext $ Leaf R   Nil):ptrs, x) $ moveR (front, back)
        (Leaf L   x) -> eval ((ReadNext $ Leaf L   Nil):ptrs, x) $ moveL (front, back)
        (Leaf In  x) -> ord <$> getChar >>= \y ->
                        eval ((ReadNext $ Leaf In  Nil):ptrs, x) (front, input y back)
        (Leaf Out x) -> (putChar $ chr $ head back) >>
                        eval ((ReadNext $ Leaf Out Nil):ptrs, x) (front, back)
        Nil          -> readBack codeZipper Nil
        Err x        -> putStrLn $ "Error:\n" ++ x
    where (front, back)    = memZipper
          incHead (x:xs)   = inc x : xs where inc x = if x < 255 then x+1 else 0
          decHead (x:xs)   = dec x : xs where dec x = if x > 0   then x-1 else 255
          moveR (x, (h:t)) = (h:x, t)
          moveL ((h:t), x) = (t, h:x)
          input x (y:ys)   = x : ys
          readBack (ptrs, tree) tmpTree
              | head back == 0 = case ptrs of
                                     ((ReadNext p):ps) -> readBack (ps, tree) (apply p tmpTree)
                                     ((FromLoop p):ps) -> readBack (ps, tree) (Loop  p tmpTree)
                                     ((ToLoop   p):ps) -> eval ((FromLoop tmpTree):ps, p) memZipper
                                     [Start]           -> return ()
                                     _                 -> putStrLn "Error"
              | otherwise      = case ptrs of
                                     ((ReadNext p):ps) -> readBack (ps, tree) (apply p tmpTree)
                                     ((FromLoop p):ps) -> readBack (ps, tree) (Loop  p tmpTree)
                                     ((ToLoop   p):ps) -> eval (ptrs, (Loop tmpTree tree)) memZipper
                                     [Start]           -> return ()
                                     _                 -> putStrLn "Error" 

rmNoises = concat.words.(concatMap (concat.takeWhile (/= "//").group)).lines

main = do
    [filePath] <- getArgs
    input <- rmNoises<$>readFile filePath
    run $ runBFParser parseBF input