# 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:

- Pushes a
`LoopL`

onto the stack on finding one. - Pops a
`LoopL`

off the stack on finding a`LoopR`

. - Returns
`False`

on finding a`LoopR`

and the stack is empty (i.e. there is a`LoopR`

without a matching`LoopL`

). - Returns
`False`

if`[BrainfuckCommand]`

is traversed and the stack is non-empty (i.e. there is at least one`LoopL`

without a matching`LoopR`

). - Returns
`True`

if`[BrainfuckCommand]`

is traversed and the stack is empty.

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 ~~. We can modify the logic of `chr`

”, not “the call to `ord`

”`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.