adrianwong programmer · retired coal miner

Writing a Brainfuck interpreter in Haskell

Or, more accurately: “Haskell scrub attempts tutorial to write a Brainfuck interpreter in an hour, takes a fortnight instead”. The tutorial already provides a minimum working implementation, so this post will cover my solutions to (most of) the optional exercises.

Part 1: Parsing Brainfuck types

Baseline implementation for Part 1:

data BrainfuckCommand = GoRight
                      | GoLeft
                      | Increment
                      | Decrement
                      | Print
                      | Read
                      | LoopL
                      | LoopR
                      | Comment Char

type BrainfuckSource = [BrainfuckCommand]

parseBrainfuck :: String -> BrainfuckSource
parseBrainfuck = map charToBf
  where
    charToBf :: Char -> BrainfuckCommand
    charToBf x = case x of
      '>' -> GoRight
      '<' -> GoLeft
      '+' -> Increment
      '-' -> Decrement
      '.' -> Print
      ',' -> Read
      '[' -> LoopL
      ']' -> LoopR
      c   -> Comment c

Exercise 1.1

mapMaybe has the type signature (a -> Maybe b) -> [a] -> [b]. This hints to us that charToBf has to be modified so its type signature is Char -> Maybe BrainfuckCommand (i.e. it should take a Char and return a BrainfuckCommand wrapped in a Maybe context).

import Data.Maybe (mapMaybe)

parseBrainfuck :: String -> BrainfuckSource
parseBrainfuck = mapMaybe charToBf
  where
    charToBf :: Char -> Maybe BrainfuckCommand
    charToBf x = case x of
      '>' -> Just GoRight
      '<' -> Just GoLeft
      '+' -> Just Increment
      '-' -> Just Decrement
      '.' -> Just Print
      ',' -> Just Read
      '[' -> Just LoopL
      ']' -> Just LoopR
      _   -> Nothing

Where the source character is a Brainfuck command, we construct a Maybe type by invoking its Just data constructor, passing in the command’s corresponding BrainfuckCommand. For all other characters, we invoke its Nothing (nullary) data constructor.

Exercise 1.2

We replace the BrainfuckSource type synonym with a BrainfuckSource data type, which has a data constructor with the same name and takes one argument:

data BrainfuckSource = BrainfuckSource [BrainfuckCommand]

We first make BrainfuckCommand an instance of the Show typeclass, which requires us to implement its show :: a -> String function. show has to return a String, which is why we have the Brainfuck source characters enclosed in double quotes:

instance Show BrainfuckCommand where
  show GoRight   = ">"
  show GoLeft    = "<"
  show Increment = "+"
  show Decrement = "-"
  show Print     = "."
  show Read      = ","
  show LoopL     = "["
  show LoopR     = "]"

We then make BrainfuckSource an instance of the Show typeclass. As BrainfuckCommand is already an instance of Show, we can map show over [BrainfuckCommand] to produce a [String] of Brainfuck source characters, which will then have to be concatenated into a String:

instance Show BrainfuckSource where
  show (BrainfuckSource x) = concat $ map show x

Also: as BrainfuckSource is now a data type, we need to modify parseBrainfuck so it invokes BrainfuckSource’s data constructor:

parseBrainfuck :: String -> BrainfuckSource
parseBrainfuck = BrainfuckSource . mapMaybe charToBf
  where
    charToBf :: Char -> Maybe BrainfuckCommand
    ...

Exercise 1.3.1

checkSyntax :: BrainfuckSource -> Maybe BrainfuckSource
checkSyntax (BrainfuckSource x) = case isValid x [] of
  True  -> Just (BrainfuckSource x)
  False -> Nothing
  where
    isValid :: [BrainfuckCommand] -> [BrainfuckCommand] -> Bool
    isValid []           []     = True
    isValid []           [_]    = False
    isValid (x@LoopL:xs) ys     = isValid xs (x : ys)
    isValid (LoopR:_)    []     = False
    isValid (LoopR:xs)   (_:ys) = isValid xs ys
    isValid (_:xs)       ys     = isValid xs ys

parseBrainfuck :: String -> Maybe BrainfuckSource
parseBrainfuck = checkSyntax . BrainfuckSource . mapMaybe charToBf
  where
    charToBf :: Char -> Maybe BrainfuckCommand
    ...

One approach we can take to implement checkSyntax is to utilise a nested function isValid. isValid traverses [BrainfuckCommand] and maintains an auxiliary stack, where it:

Note: we could have just used a simple counter, but I read ahead and knew how I wanted to implement exercises 1.3.2 and 1.3.3.

Exercise 1.3.2

checkSyntax :: BrainfuckSource -> Either String BrainfuckSource
checkSyntax (BrainfuckSource x) = case isInvalid x [] of
  Just x  -> case x of
    LoopL -> Left "Mismatched opening parenthesis"
    LoopR -> Left "Mismatched closing parenthesis"
  Nothing -> Right (BrainfuckSource x)
  where
    isInvalid :: [BrainfuckCommand] -> [BrainfuckCommand] -> Maybe BrainfuckCommand
    isInvalid []           []     = Nothing
    isInvalid []           (x:_)  = Just x
    isInvalid (x@LoopL:xs) ys     = isInvalid xs (x : ys)
    isInvalid (x@LoopR:_)  []     = Just x
    isInvalid (LoopR:xs)   (_:ys) = isInvalid xs ys
    isInvalid (_:xs)       ys     = isInvalid xs ys

parseBrainfuck :: String -> Either String BrainfuckSource
parseBrainfuck = checkSyntax . BrainfuckSource . mapMaybe charToBf

We can take the approach of replacing isValid with its inverse isInvalid, which returns the offending parenthesis wrapped in a Maybe context. That way, the parent function checkSyntax is able to deconstruct the Maybe to get to the wrapped parenthesis.

Exercise 1.3.3

type BfCmdPos = (BrainfuckCommand, Int)

checkSyntax :: BrainfuckSource -> Either String BrainfuckSource
checkSyntax (BrainfuckSource x) = case isInvalid (zip x [1..]) [] of
  Just x  -> case x of
    (LoopL, n) -> Left ("Col " ++ show n ++ ": '" ++ show LoopL ++
                        "' without matching '" ++ show LoopR ++ "'")
    (LoopR, n) -> Left ("Col " ++ show n ++ ": '" ++ show LoopR ++
                        "' without matching '" ++ show LoopL ++ "'")
  Nothing -> Right (BrainfuckSource x)
  where
    isInvalid :: [BfCmdPos] -> [BfCmdPos] -> Maybe BfCmdPos
    isInvalid []                []     = Nothing
    isInvalid []                (x:_)  = Just x
    isInvalid (x@(LoopL, _):xs) ys     = isInvalid xs (x : ys)
    isInvalid (x@(LoopR, _):_)  []     = Just x
    isInvalid ((LoopR, _):xs)   (_:ys) = isInvalid xs ys
    isInvalid (_:xs)            ys     = isInvalid xs ys

By taking the approach we did in exercise 1.3.2, this exercise is made fairly trivial. All we need to do is zip [BrainfuckCommand] with a list of integers, so each BrainfuckCommand and its position are stored in a tuple.

Note: for brevity, we define a type synonym for the tuple: type BfCmdPos = (BrainfuckCommand, Int).

Part 2: Building the tape

Baseline implementation for Part 2:

data Tape a = Tape [a] a [a]

emptyTape :: Tape Int
emptyTape = Tape zeros 0 zeros
  where zeros = repeat 0

moveRight :: Tape a -> Tape a
moveRight (Tape ls p (r:rs)) = Tape (p:ls) r rs

moveLeft :: Tape a -> Tape a
moveLeft (Tape (l:ls) p rs) = Tape ls l (p:rs)

Exercise 2.1

instance Functor Tape where
  fmap f (Tape ls p rs) = Tape (map f ls) (f p) (map f rs)

Straightforward, but does it satisfy the two functor laws? Let’s find out!

1st law: fmap id = id:

fmap id (Tape ls p rs)
  = Tape (map id ls) (id p) (map ld rs)
  = Tape ls p rs
  = id (Tape ls p rs)

2nd law: fmap (g . f) = fmap g . fmap f:

fmap (g . f) (Tape ls p rs)
  = Tape (map (g . f) ls) ((g . f) p) (map (g . f) rs)
  = Tape (map g (map f ls)) (g (f p)) (map g (map f rs))
  = fmap g (fmap f (Tape ls p rs))
  = (fmap g . fmap f) (Tape ls p rs)

Exercise 2.2

Not sure why this was marked as a “medium” difficulty exercise. Unless I’ve completely misunderstood, all we need to do here is have moveRight and moveLeft return a Maybe (Tape a):

moveRight :: Tape a -> Maybe (Tape a)
moveRight (Tape ls p (r:rs)) = Just (Tape (p:ls) r rs)
moveRight (Tape ls p [])     = Nothing

moveLeft :: Tape a -> Maybe (Tape a)
moveLeft (Tape (l:ls) p rs) = Just (Tape ls l (p:rs))
moveLeft (Tape []     p rs) = Nothing

Exercise 2.3.1

data Stream a = Cons a (Stream a)

head :: Stream a -> a
head (Cons x _) = x

map :: (a -> b) -> Stream a -> Stream b
map f (Cons x xs) = Cons (f x) (map f xs)

repeat :: a -> Stream a
repeat x = Cons x (repeat x)

tail :: Stream a -> Stream a
tail (Cons _ xs) = xs

Note: Stream is an example of a recursive data type!

Also, even though it wasn’t required for this exercise, my implementation for making Stream an instance of Functor, Applicative and Monad can be found here. It was rather fun comparing my implementation against Haskell’s Data.Stream module, which is what I used for the rest of the tutorial.

Exercise 2.3.2

Genericising Tape so it takes the type of container:

data Tape m a = Tape (m a) a (m a)

We’ll also have to modify the code where we make Tape an instance of Functor. The Functor typeclass requires a type constructor take takes only one type parameter, so we can partially apply Tape:

instance Functor (Tape m) where
  fmap f (Tape ls p rs) = Tape (map f ls) (f p) (map f rs)

This, predictably, gives us an error. map is expecting a type [a], when we’re now passing in an m a. Well, why not call the generic fmap instead?

instance Functor (Tape m) where
  fmap f (Tape ls p rs) = Tape (fmap f ls) (f p) (fmap f rs)

error:
  No instance for (Functor m) arising from a use of `fmap`
    Possible fix:
      add (Functor m) to the context of
        the type signature for:
          fmap :: forall a b. (a -> b) -> Tape m a -> Tape m b
        or the instance declaration
  ...

The error message we get is informative: we have to constrain m so it is a Functor if we want to dispatch to m’s fmap function. Without this constraint, the compiler will throw an error as it can’t introspect the unconstrained m to determine if it implements Functor. So:

instance Functor m => Functor (Tape m) where
  fmap f (Tape ls p rs) = Tape (fmap f ls) (f p) (fmap f rs)

We also provide emptyTape, moveRight and moveLeft implementations for Tape [] and Tape Stream:

import Data.Stream (Stream(..))
import qualified Data.Stream as S

emptyTapeL :: Tape [] Int
emptyTapeL = Tape zeros 0 zeros
  where zeros = repeat 0

moveRightL :: Tape [] a -> Maybe (Tape [] a)
moveRightL (Tape ls p (r:rs)) = Just (Tape (p:ls) r rs)
moveRightL (Tape ls p [])     = Nothing

moveLeftL :: Tape [] a -> Maybe (Tape [] a)
moveLeftL (Tape (l:ls) p rs) = Just (Tape ls l (p:rs))
moveLeftL (Tape []     p rs) = Nothing

emptyTapeS :: Tape Stream Int
emptyTapeS = Tape zeros 0 zeros
  where zeros = S.repeat 0

moveRightS :: Tape Stream a -> Tape Stream a
moveRightS (Tape ls p (Cons r rs)) = Tape (Cons p ls) r rs

moveLeftS :: Tape Stream a -> Tape Stream a
moveLeftS (Tape (Cons l ls) p rs) = Tape ls l (Cons p rs)

Part 3: Evaluating Brainfuck source code

Baseline implementation for Part 3. Because of the changes made in Parts 1 and 2, the code here deviates from the exercise a fair bit:

import Data.Char (chr, ord)
import System.IO (hFlush, stdout)

type DataTape   = Tape Stream Int
type SourceTape = Tape [] BrainfuckCommand

runBrainfuck :: BrainfuckSource -> IO ()
runBrainfuck = run emptyTapeS . bfSource2Tape
  where
    bfSource2Tape :: BrainfuckSource -> SourceTape
    bfSource2Tape (BrainfuckSource (b:bs)) = Tape [] b bs

run :: DataTape -> SourceTape -> IO ()
run dataTape source@(Tape _ GoRight _)   = advance (moveRightS dataTape) source
run dataTape source@(Tape _ GoLeft _)    = advance (moveLeftS dataTape)  source

run (Tape l p r) source@(Tape _ Increment _) = advance (Tape l (p+1) r) source
run (Tape l p r) source@(Tape _ Decrement _) = advance (Tape l (p-1) r) source

run dataTape@(Tape _ p _) source@(Tape _ Print _) = do
  putChar (chr p)
  hFlush stdout
  advance dataTape source
run dataTape@(Tape l _ r) source@(Tape _ Read _)  = do
  p <- getChar
  advance (Tape l (ord p) r) source

run dataTape@(Tape _ p _) source@(Tape _ LoopL _)
  | p == 0    = seekLoopR 0 dataTape source
  | otherwise = advance dataTape source

run dataTape@(Tape _ p _) source@(Tape _ LoopR _)
  | p /= 0    = seekLoopL 0 dataTape source
  | otherwise = advance dataTape source

run dataTape source@(Tape _ (Comment _) _) = advance dataTape source

seekLoopR :: Int -> DataTape -> SourceTape -> IO ()
seekLoopR 1 dataTape source@(Tape _ LoopR _) = advance dataTape source
seekLoopR b dataTape source@(Tape _ LoopR _) = case (moveRightL source) of
  Just bs -> seekLoopR (b-1) dataTape bs
  Nothing -> return ()
seekLoopR b dataTape source@(Tape _ LoopL _) = case (moveRightL source) of
  Just bs -> seekLoopR (b+1) dataTape bs
  Nothing -> return ()
seekLoopR b dataTape source                  = case (moveRightL source) of
  Just bs -> seekLoopR b dataTape bs
  Nothing -> return ()

seekLoopL :: Int -> DataTape -> SourceTape -> IO ()
seekLoopL 1 dataTape source@(Tape _ LoopL _) = advance dataTape source
seekLoopL b dataTape source@(Tape _ LoopL _) = case (moveLeftL source) of
  Just bs -> seekLoopL (b-1) dataTape bs
  Nothing -> return ()
seekLoopL b dataTape source@(Tape _ LoopR _) = case (moveLeftL source) of
  Just bs -> seekLoopL (b+1) dataTape bs
  Nothing -> return ()
seekLoopL b dataTape source                  = case (moveLeftL source) of
  Just bs -> seekLoopL b dataTape bs
  Nothing -> return ()

advance :: DataTape -> SourceTape -> IO ()
advance dataTape source = case (moveRightL source) of
  Just bs -> run dataTape bs
  Nothing -> return ()

For brevity, we define DataTape and SourceTape as type synonyms for Tape Stream Int and Tape [] BrainfuckCommand respectively.

Exercise 3.1

The suggested approach feels rather… hacky. But hey, it works! When we provide bfSource2Tape with an empty [BrainfuckCommand], we can simply return a SourceTape containing a throwaway Comment:

runBrainfuck :: BrainfuckSource -> IO ()
runBrainfuck = run emptyTapeS . bfSource2Tape
  where
    bfSource2Tape :: BrainfuckSource -> SourceTape
    bfSource2Tape (BrainfuckSource [])     = Tape [] (Comment '_') []
    bfSource2Tape (BrainfuckSource (b:bs)) = Tape [] b bs

Exercise 3.2

** Update (24 Jun 2018): yes, it’s chr.

I’m fairly certain the exercise means to say “the call to chr”, not “the call to ord. We can modify the logic of run so that it only outputs ASCII characters:

run dataTape@(Tape _ p _) source@(Tape _ Print _)
  | 0 <= p && p <= 127 = putASCII p
  | otherwise          = advance dataTape source
  where
    putASCII :: Int -> IO ()
    putASCII p = do
      putChar (chr p)
      hFlush stdout
      advance dataTape source

Exercise 3.3

R-r-refactor! (I didn’t do a very good job here; I’m sure some of these functions can be made more succinct).

Reducing repetition for seekLoopR and seekLoopL:

seekLoopR :: Int -> DataTape -> SourceTape -> IO ()
seekLoopR 1 dataTape source@(Tape _ LoopR _) = advance dataTape source
seekLoopR b dataTape source@(Tape _ cmd   _) = case cmd of
  LoopR -> seekLoopRInner ((-)1)
  LoopL -> seekLoopRInner (+1)
  _     -> seekLoopRInner id
  where
    seekLoopRInner f = case (moveRightL source) of
      Just bs -> seekLoopR (f b) dataTape bs
      Nothing -> return ()

seekLoopL :: Int -> DataTape -> SourceTape -> IO ()
seekLoopL 1 dataTape source@(Tape _ LoopL _) = advance dataTape source
seekLoopL b dataTape source@(Tape _ cmd   _) = case cmd of
  LoopR -> seekLoopLInner ((-)1)
  LoopL -> seekLoopLInner (+1)
  _     -> seekLoopLInner id
  where
    seekLoopLInner f = case (moveLeftL source) of
      Just bs -> seekLoopL (f b) dataTape bs
      Nothing -> return ()

All in all, this was a fun exercise! Complete implementation can be found here.