Haskell Brainf*ck interpreter: runtime error handling

Question

I have designed a Brainf*ck interpreter in Haskell.

I would appreciate the code review, especially any tips related to error handling (e.g. parsing errors, runtime errors, etc.).

{-
Brainf**k interpreter

Instructions:
>   Increment data pointer so that it points to next location in memory.
<   Decrement data pointer so that it points to previous location in memory.
+   Increment the byte pointed by data pointer by 1. If it is already at its maximum value, 255, then new value will be 0.
-   Decrement the byte pointed by data pointer by 1. If it is at its minimum value, 0, then new value will be 255.
.   Output the character represented by the byte at the data pointer.
,   Read one byte and store it at the memory location pointed by data pointer.
[   If the byte pointed by data pointer is zero, then move instruction pointer to next matching ']', otherwise move instruction pointer to next command.
]   If the byte pointed by data pointer is non-zero, then move instruction pointer to previous matching '[' command, otherwise to next command.

Example. The first line of hello-world.bf must contain the input ('$' means there is no input).

hello-world.bf:
$
+++++ +++++             initialize counter (cell #0) to 10
[                       use loop to set the next four cells to 70/100/30/10
    > +++++ ++              add  7 to cell #1
    > +++++ +++++           add 10 to cell #2
    > +++                   add  3 to cell #3
    > +                     add  1 to cell #4
    <<<< -                  decrement counter (cell #0)
]
> ++ .                  print 'H'
> + .                   print 'e'
+++++ ++ .              print 'l'
.                       print 'l'
+++ .                   print 'o'
> ++ .                  print ' '
<< +++++ +++++ +++++ .  print 'W'
> .                     print 'o'
+++ .                   print 'r'
----- - .               print 'l'
----- --- .             print 'd'
> + .                   print '!'

$ ghc -O2 brainf.hs
$ ./brainf < hello-world.bf
Hello World!
-}

{-# LANGUAGE BangPatterns #-}

import qualified Data.Vector.Storable as V
import           Data.Word ( Word8 )
import           Data.Char ( chr )
import qualified Data.Map.Strict as Map
import qualified GHC.Prim as Prim
import           Unsafe.Coerce ( unsafeCoerce )
import           Debug.Trace

newtype MemCell = MemCell Word8 deriving Show
type Memory = [MemCell]
type Instructions = V.Vector Char
type JumpMap = Map.Map Position Position
-- The program consists of an instructions vector and matching brackets map.
-- This could be replaced with a double-linked (bidirectional) tree
type Program = (Instructions, JumpMap)
-- Currently executed command position
newtype Position = Position Int deriving (Show, Ord, Eq)
type Input = (Char, Word8)  -- Instruction and external input
type Counter = Int
data State = State Memory Memory Position
type Output = (Maybe Char, CMD)
data CMD = Continue | Jump Direction deriving (Show, Eq)
data Direction = L | R deriving (Show, Eq)

incP  = '>'
decP  = '<'
incB  = '+'
decB  = '-'
prnt  = '.'
rd    = ','
moveR = '['
moveL = ']'

parse :: String -> Program
parse s = (V.fromList instrucs, buildMap 0 [] instrucs)
  where
    instrucs = filter f $ s
    f x | x == incP = True
        | x == decP = True
        | x == incB = True
        | x == decB = True
        | x == prnt = True
        | x == rd   = True
        | x == moveR = True
        | x == moveL = True
        | otherwise = False

    buildMap :: Int -> [Int] -> [Char] -> Map.Map Position Position
    buildMap _ _ [] = Map.empty
    buildMap pos stack (x:xs) = r
      where r | x == moveR = buildMap pos' (pos:stack) xs
              | x == moveL = Map.insert (Position pos) (Position s) (Map.insert (Position s) (Position pos) $ buildMap pos' ss xs)
              | otherwise = buildMap pos' stack xs
            pos' = pos + 1
            s = head stack
            ss = tail stack

initial :: State
initial = State [] (repeat (MemCell 0)) (Position 0)

pu :: State -> Input -> (State, Output)
pu state@(State memL memR@((MemCell cell):tMemR) (Position pos)) (instruc, inpt) = (state', (out, cmd))
  where state' = State memL' memR' (Position pos')
        pos' = 0  -- Dummy

        memR' | instruc == incB = (MemCell (cell + 1)) : tMemR
              | instruc == decB = (MemCell (cell - 1)) : tMemR
              | instruc == rd = (MemCell inpt) : tMemR
              | instruc == incP = tMemR
              | instruc == decP = (head memL) : memR
              | otherwise = memR

        memL' | instruc == incP = (MemCell cell) : memL
              | instruc == decP = tail memL
              | otherwise = memL

        out | instruc == prnt = Just (chr . fromIntegral $ cell)
            | otherwise = Nothing

        cmd | instruc == moveR = Jump R
            | instruc == moveL = Jump L
            | otherwise = Continue

getInstruc :: Instructions -> Position -> Char
getInstruc prg (Position pos) = prg V.! pos

jump :: CMD -> JumpMap -> MemCell -> Position -> Position
jump (Jump R) jm (MemCell 0) pos = jm Map.! pos
jump (Jump R) _ _ (Position i) = Position $ i + 1
jump (Jump L) _ (MemCell 0) (Position i) = Position $ i + 1
jump (Jump L) jm _ pos = jm Map.! pos

handler :: Program -> State -> Int -> [Word8] -> IO String
handler prg@(!instr, !jumpMap) state@(State memL memR@(cell:_) pos@(Position !i)) !cnt input = r
  where
    ((State memL' memR' _), (out, cmd)) = pu state (instruc, head input)

    instruc = instr `getInstruc` pos
    input' = if instruc == rd
               then (tail input)
               else input

    pos' = case cmd of
             Jump _ -> jump cmd jumpMap cell pos
             otherwise -> Position (i + 1)

    r | cnt == maxIter = return "\n(Reached maximal number of iterations)"
      | i == V.length instr = return ""  -- Normal termination
      | otherwise = do
          r1 <- handler prg (State memL' memR' pos') (cnt + 1) input'

          let m Nothing = r1
              m (Just chr) = chr : r1
          return $ m out

interpret = handler

toWord8 :: Char -> Word8
toWord8 = unsafeCoerce

maxIter = 100000

main = do
  input <- map toWord8 <$> getLine

  code <- getContents
  let program = parse code

  interpret program initial 0 input >>= putStr

[Update]

The latest version with respect to the code review by Zeta, is here https://gist.github.com/masterdezign/2c3eae1aadaa3f84aa148c6ee9747ac9

Answer 1

When you compile a language, you usually split the input into tokens with a lexer, then parse those tokens with a parser into syntactic elements in an abstract syntax tree (AST) and then use that to optimize the program and finally generate machine code.

With Brainfuck, none of this is really necessary, but it makes your code much easier to understand, especially the AST. The biggest problem in my point of view is that you don't actually have a program at the end. Your parse results in a Vector Char and a jump map, which by the way is not complete. Try the (malformed) programs ,[[.,] or ,[.,]]. The latter will result in a "head called on empty list" error, the first will silently ignore the [ during parse but will crash during interpretation.

The latter error is too late. It should have been found during the parsing step. However, this is a lot easier if you use a new datatype:

type Program = [BFInstruction]

-- Can be also used as a toy for Free, but that's a little bit too much.
-- But if you come back to this code in some months, have a look at
-- "Free monads" and the "free" package for some fun.
-- In some months, mind you!
data BFInstruction = BFNext | BFPrev   -- memory movements
                   | BFInc  | BFDec    -- increment / decrement
                   | BFPut  | BFGet    -- to stdout / from stdin
                   | BFLoop Program    -- loops

If you parse your program into a Program, there's no way you can accidentally end up with a superfluous [, since your type does not allow that. That's a big promise, so I repeat it: if we have a Program, we can be certain that it's well-formed.

By the way, your f in parse can be heavily simplified:

instrucs = filter f $ s
  where
    f x = x `elem` [incP, decP, incB, decB, prnt, rd, moveR, moveL]

Either way, back to parsing. I suggest you to write parse :: String -> Either String Program. In any ASCII text, there can be only two parser errors:

• unexpected ], e.g. ]->
• unclosed [, e.g. [++

Now, parse will probably get a little bit harder, but not too much:

parse []     = Right []
parse (x:xs) = 
  case x of
    '>' -> BFNext <$:> parse xs
    '<' -> BFPrev <$:> parse xs
    '+' -> BFInc  <$:> parse xs
    '-' -> BFDec  <$:> parse xs
    '.' -> BFPut  <$:> parse xs
    ',' -> BFGet  <$:> parse xs
    '[' -> handleLoop xs         -- left as exercise
    ']' -> Left "Unexpected ']'" -- ']' should get handled by handleLoop
    _   -> parse xs

-- I'm too lazy to use `fmap` above all the time. Remember, we 
-- return `Right` or `Left` in `parse` therefore we cannot simply
-- use (:) to map our values
x <$:> xs = fmap (x:) xs

You can heavily improve the parser if you add line and column numbers to the parser error, but that's for another time.

For memory, I suggest you to use a separate data type for the whole memory, not for the parts left and right of the current cursor. Something like

data Tape = Tape [Word8] Word8 [Word8]

comes in mind. You can still use the same logic as above, but now the (possibly infinite) tape can get tested without running an actual brainfuck program. As an exercise, write

forward  :: Tape -> Tape
backward :: Tape -> Tape
modify   :: (Word8 -> Word8) -> Tape -> Tape
value    :: Tape -> Word8

If you follow that approach, you don't need a JumpMap anymore, nor will you need your State (it has been replaced by Tape).

Now that we have the data types out of the way: it's good that you have some type signatures, but it's a shame that you left them at some point. And the use of unsafeCoerce is really unsafe there. A Char does not consists of a single byte, a Char is a unicode character. You can use fromIntegral . fromEnum, although you still want to handle those cases where the character value exceeds 255.

So we now have a Program, a Tape and all of that. Those are alternative solutions. So, why do I even propose them? Because they make your other functions easier. Let us have a look at pu:

pu :: State -> Input -> (State, Output)
pu state@(State memL memR@((MemCell cell):tMemR) (Position pos)) (instruc, inpt) = (state', (out, cmd))
  where state' = State memL' memR' (Position pos')
        pos' = 0  -- Dummy

        memR' | instruc == incB = (MemCell (cell + 1)) : tMemR
              | instruc == decB = (MemCell (cell - 1)) : tMemR
              | instruc == rd = (MemCell inpt) : tMemR
              | instruc == incP = tMemR
              | instruc == decP = (head memL) : memR
              | otherwise = memR

        memL' | instruc == incP = (MemCell cell) : memL
              | instruc == decP = tail memL
              | otherwise = memL

        out | instruc == prnt = Just (chr . fromIntegral $ cell)
            | otherwise = Nothing

        cmd | instruc == moveR = Jump R
            | instruc == moveL = Jump L
            | otherwise = Continue

There's a lot going on there. Now, if we use our Tape and BFInstruction, the code gets tremendously easier:

pu :: BFInstruction -> Tape -> String -> (String, String, Tape)
pu i t input = 
  case i of
    BFInc    -> taped $ modify (+1) t
    BFDec    -> taped $ modify (subtract 1) t
    BFPrev   -> taped $ backward t
    BFNext   -> taped $ forward t
    BFGet    -> ("", tail input, modify (const (head input)) tape) -- type error here, but easy to fix
    BFPut    -> (value tape, input, tape) -- type error, easy to fix
    BFLoop p | value t /= 0 -> runLoop p
    _        -> taped t

 where 
   taped t' = ("", input, t') -- no output, no input consumption

Instead of guards with ==, you now compare to data constructors. This has the nice side-effect that the compiler can now warn you if you forgot an instruction. And all just because we went from String to [BFInstruction]. We eliminated a bunch of mistakes that can happen there. Note that I left runLoop out since it is a little bit difficult to write with those types; it's a lot easier if we used another data type. But it's possible with (String, String, Tape).