Brainfuck Interpreter

Question

I want to write an example for a language similar to Haskell called Frege. While the interpreter is conceptually easy, it is lengthy and looks still quite messy. Note that I don't want to use Parsec etc, as it isn't available yet in Frege. Please help me to improve the Haskell version.

import Data.Char

data Tape = Tape { left :: [Int], cell :: Int, right :: [Int] }

instance Show Tape where
   show (Tape ls c rs) = show [reverse ls,[c],rs]

data Op = Plus | Minus | GoLeft | GoRight | Output | Input | Loop [Op] deriving (Eq, Show)

removeComments :: [Char] -> [Char]
removeComments xs = filter (`elem` "+-<>.,[]") xs

parseOp :: [Char] -> Maybe (Op, [Char])
parseOp ('+':cs) = Just (Plus, cs)
parseOp ('-':cs) = Just (Minus, cs)
parseOp ('<':cs) = Just (GoLeft, cs)
parseOp ('>':cs) = Just (GoRight, cs)
parseOp ('.':cs) = Just (Output, cs)
parseOp (',':cs) = Just (Input, cs)
parseOp ('[':cs) = case parseOps cs of
  (prog, (']':cs')) -> Just (Loop prog, cs')
  _ -> Nothing
parseOp _ = Nothing

parseOps :: [Char] -> ([Op],[Char])
parseOps cs = go cs [] where
  go cs acc = case parseOp cs of
    Nothing -> (reverse acc, cs)
    Just (op, cs') -> go cs' (op:acc)

parse :: String -> [Op]
parse prog = case parseOps $ removeComments $ prog of
   (ops, []) -> ops
   (ops, rest) -> error $ "Parsed: " ++ show ops ++ ", Rest: " ++ rest

execute :: [Op] -> IO Tape
execute prog = exec prog (Tape [] 0 [])

exec :: [Op] -> Tape -> IO Tape
exec [] tape = return tape
exec (Plus:prog) (Tape ls c rs) = exec prog (Tape ls (c+1) rs)
exec (Minus:prog) (Tape ls c rs) = exec prog (Tape ls (c-1) rs)
exec (GoLeft:prog) (Tape ls c rs) =
  let (hd,tl) = uncons ls in exec prog (Tape tl hd (c:rs))
exec (GoRight:prog) (Tape ls c rs) =
  let (hd,tl) = uncons rs in exec prog (Tape (c:ls) hd tl)
exec (Output:prog) tape = do
  printAsChar (cell tape)
  exec prog tape
exec (Input:prog) (Tape ls _ rs) = do
  n <- getChar
  exec prog (Tape ls (digitToInt n) rs)
exec (Loop loop:prog) tape @ (Tape ls 0 rs) = exec prog tape
exec again@(Loop loop:prog) tape = do
  tape' <- exec loop tape
  exec (if (cell tape') == 0 then prog else again) tape'

uncons :: [Int] -> (Int,[Int])
uncons [] = (0,[])
uncons (x:xs) = (x,xs)


printAsChar :: Int -> IO ()
printAsChar i = putStr $ [chr i]

main = do
  tape <- execute $ parse helloWorld
  putStrLn $ "\n" ++ show tape ++ "\n"

helloWorld =
  ">+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++" ++
  "[<++++>-]<.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------." ++
  "[-]>++++++++[<++++>-]<+.[-]++++++++++."

[Edit]

parseOp can be simplified to:

ops = [('+', Plus),('-', Minus),('<',GoLeft),('>',GoRight),('.',Output),(',',Input)]

parseOp :: [Char] -> Maybe (Op, [Char])
parseOp ('[':cs) = case parseOps cs of
  (prog, (']':cs')) -> Just (Loop prog, cs')
  _ -> Nothing
parseOp (c:cs) = fmap (flip (,) cs) $ lookup c ops
parseOp [] = Nothing

Answer 1

Disclaimer: I know nothing about Frege, all comments apply to Haskell only.

1)

Running hlint on your code shows places where you can remove $ and brackets. Please do it!

2)

In exec, you always do exec prog tape after finishing current instruction. So you are iterating the list in some sense. This is a fold.

exec :: [Op] -> Tape -> IO Tape
exec prog tape = foldM f tape prog

  where f (Tape ls c rs) Plus    = return $ Tape ls (c+1) rs
        f (Tape ls c rs) Minus   = return $ Tape ls (c-1) rs
        f (Tape ls c rs) GoLeft  = let (hd, tl) = uncons ls in return $ Tape tl hd (c:rs)
        f (Tape ls c rs) GoRight = let (hd, tl) = uncons rs in return $ Tape (c:ls) hd tl
        f tape           Output  = printAsChar (cell tape) >> return tape
        f (Tape ls _ rs) Input   = do n <- getChar
                                      return $ Tape ls (digitToInt n) rs

        f tape again@(Loop loop) | cell tape == 0 -> return tape
                                 | otherwise -> do tape' <- exec loop tape
                                                   f tape' again

3)

printAsChar i = putStr $ [chr i]

hlint will tell you the $ is redundant:

printAsChar i = putStr [chr i]

You can use putChar:

printAsChar i = putChar (chr i)

and finally get:

printAsChar =  putChar . chr

You have a strange asymmetry - output uses chr, and input digitToInt. These are not inverses! digitToInt '0' is 0, but chr 0 is '\NUL', not '0'.

If you want to output numbers longer than 1 character, use

printAsString = putStr . show

4)

I would merge execute and exec:

 execute :: [Op] -> IO Tape
 execute = foldM f (Tape [] 0 [])
   where f = ...

5)

 putStrLn $ "\n" ++ show tape ++ "\n" 

putStrLn already adds '\n" to the end, you might remove it.

6)

If you remove the requirement to print the tape (is it needed for debugging only?), you can use an infinite list:

 execute = foldM f (Tape (repeat 0) 0 (repeat 0))

and get rid of uncons:

       f (Tape (hd:tl) c rs) GoLeft  = return $ Tape tl hd (c:rs)
       f (Tape ls c (hd:tl)) GoRight = return $ Tape (c:ls) hd tl