Brainfuck interpreter in Haskell

Question

Okay, so I just started learning Haskell around a week ago and this is my first real program that I worked on all of yesterday with a lot of help from IRC. I know that using indicies and arrays is not very "Haskellish" but I found constantly manipulating lists and traversing them was extremely slow and sometimes the program took over 10 minutes to execute while this version is instant.

Afterwards I found you can do it with some Zipper package in 10 lines of code trivially but I didn't want to use anything too fancy.

I find that when I'm writing Haskell because there is no state I find myself simulating state with function parameters (saving variables and mutating them in a recursive call). I'm pretty sure I took it too far because most of these functions take four parameters and rarely change them but I'm not sure about many alternatives.

I haven't gotten to monads, functors, or applicatives yet, so while I'm sure they could solve this quite elegantly, they're still just magic to me. Unless the explanation is quite simple, I'd prefer if replies didn't mention them. I'm mostly looking for refactorings, style-advice, and better ways of implementing some things.

import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
-- Current Index, Indentation Depth, Program Array -> Bracket Index
prevBracketIndex :: Int -> Int -> Array Int Char -> Int
prevBracketIndex i depth cs
 | cs ! i == '[' = if (depth - 1) == 0 then i else prevBracketIndex (i - 1) (depth - 1) cs
 | cs ! i == ']' = prevBracketIndex (i - 1) (depth + 1) cs
 | otherwise = prevBracketIndex (i - 1) depth cs
nextBracketIndex :: Int -> Int -> Array Int Char -> Int
nextBracketIndex i depth cs
 | cs ! i == '[' = nextBracketIndex (i + 1) (depth + 1) cs
 | cs ! i == ']' = if (depth - 1) == 0 then i else nextBracketIndex (i + 1) (depth - 1) cs
 | otherwise = nextBracketIndex (i + 1) depth cs
execCode :: Int -> S.Seq Int -> Int -> Array Int Char -> IO ()
execCode tapePos ts codePos cs
 | codePos == (snd . bounds $ cs) = return ()
 | cmd == '+' = execCode tapePos (S.update tapePos (value + 1) ts) nextPos cs
 | cmd == '-' = execCode tapePos (S.update tapePos (value - 1) ts) nextPos cs
 | cmd == '>' = execCode (tapePos + 1) ts nextPos cs
 | cmd == '<' = execCode (tapePos - 1) ts nextPos cs
 | cmd == '[' && value == 0 = execCode tapePos ts (nextBracketIndex codePos 0 cs + 1) cs
 | cmd == ']' && value /= 0 = execCode tapePos ts (prevBracketIndex codePos 0 cs + 1) cs
 | cmd == '.' = putStr [chr $ S.index ts tapePos] >> execCode tapePos ts nextPos cs
 | cmd == ',' = do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos cs }
 | otherwise = execCode tapePos ts nextPos cs
 where value = S.index ts tapePos
 cmd = cs ! codePos
 nextPos = codePos + 1
tape = S.fromList $ replicate 30000 0
main = do
 file <- readFile "example.bf"
 execCode 0 tape 0 (listArray (0, length file - 1) file)

Answer 1

Use case instead of == and guards everywhere:

prevBracketIndex :: Int -> Int -> Array Int Char -> Int
prevBracketIndex i depth cs = case cs ! i of
 '[' -> if (depth - 1) == 0 then i else prevBracketIndex (i - 1) (depth - 1) cs
 ']' -> prevBracketIndex (i - 1) (depth + 1) cs
 _ -> prevBracketIndex (i - 1) depth cs

Use State and lens to carry state around instead of manual threading.

Use monad-loops to spin the loop instead of manual tail calls.

prevBracketIndex should avoid recursion too by using lists of indices.

Initial depth is always 0 in prevBracketIndex so it should be made local to improve readability. Also, cs is not changed across recursive calls so there is no need to pass it across. Applying both ideas:

prevBracketIndex :: Int -> Array Int Char -> Int
prevBracketIndex i cs = pbi i 0 where
 pbi i depth = case cs ! i of
 '[' -> if (depth - 1) == 0 then i else pbi (i - 1) (depth - 1)
 ']' -> pbi (i - 1) (depth + 1)
 _ -> pbi (i - 1) depth

For execCode we can do the same transformation: cs is invariant across loops, and initial positions are always 0.

Note also that prevBracketIndex can be completely precalculated (replaced by a single array lookup), as cs doesn't change.

Applying everything above but case we get:

import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
import Data.List
cachePrev cs = listArray (bounds cs) $ snd $ mapAccumL f [] $ assocs cs where
 f l (i, c) = case c of
 '[' -> (i : l, Nothing)
 ']' -> (tail l, Just $ head l)
 _ -> (l, Nothing)
cacheNext cs = listArray (bounds cs) $ snd $ mapAccumR f [] $ assocs cs where
 f l (i, c) = case c of
 ']' -> (i : l, Nothing)
 '[' -> (tail l, Just $ head l)
 _ -> (l, Just i)
cache arr i = case arr ! i of
 Nothing -> error "oops!"
 Just idx -> idx
execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = execCode 0 ts 0 where
 prev = cachePrev cs
 next = cacheNext cs
 execCode tapePos ts codePos
 | codePos == (snd . bounds $ cs) = return ()
 | cmd == '+' = execCode tapePos (S.update tapePos (value + 1) ts) nextPos
 | cmd == '-' = execCode tapePos (S.update tapePos (value - 1) ts) nextPos
 | cmd == '>' = execCode (tapePos + 1) ts nextPos
 | cmd == '<' = execCode (tapePos - 1) ts nextPos
 | cmd == '[' && value == 0 = execCode tapePos ts (cache next codePos + 1)
 | cmd == ']' && value /= 0 = execCode tapePos ts (cache prev codePos + 1)
 | cmd == '.' = putStr [chr $ S.index ts tapePos] >> execCode tapePos ts nextPos
 | cmd == ',' = do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
 | otherwise = execCode tapePos ts nextPos
 where
 value = S.index ts tapePos
 cmd = cs ! codePos
 nextPos = codePos + 1

For tests I found csFromString to be a convenient helper:

csFromString file = listArray (0, length file - 1) file

And it helps to write main in a more compact way:

main = readFile "example.bf" >>= execCode' tape . csFromString

Now let's apply the case proposal:

execCode _ _ codePos | codePos == (snd . bounds $ cs) = return ()
execCode tapePos ts codePos = case cs ! codePos of
 '+' -> execCode tapePos (S.update tapePos (value + 1) ts) nextPos
 '-' -> execCode tapePos (S.update tapePos (value - 1) ts) nextPos
 '>' -> execCode (tapePos + 1) ts nextPos
 '<' -> execCode (tapePos - 1) ts nextPos
 '[' -> if value == 0 then execCode tapePos ts (cache next codePos + 1) else execNext 
 ']' -> if value /= 0 then execCode tapePos ts (cache prev codePos + 1) else execNext
 '.' -> putStr [chr $ S.index ts tapePos] >> execNext
 ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
 _ -> execNext
 where
 value = S.index ts tapePos
 nextPos = codePos + 1
 execNext = execCode tapePos ts nextPos

Now cmd is not needed anymore, and [ and ] required some additional plumbing.

Now let's remove duplication in 3 symmetrical pairs of instructions - updatePos, updateVal and branch:

execCode _ _ codePos | codePos == (snd . bounds $ cs) = return ()
execCode tapePos ts codePos = case cs ! codePos of
 '+' -> updatePos succ
 '-' -> updatePos pred
 '>' -> updateVal succ
 '<' -> updateVal pred
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> putStr [chr $ S.index ts tapePos] >> execNext
 ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
 _ -> execNext
 where
 value = S.index ts tapePos
 nextPos = codePos + 1
 execNext = execCode tapePos ts nextPos
 updatePos f = execCode tapePos (S.update tapePos (f value) ts) nextPos
 updateVal f = execCode (f tapePos) ts nextPos
 branch cond dir = if cond value then execCode tapePos ts (cache dir codePos + 1) else execNext

Now it's time to remove duplication between cachePrev and cacheNext:

mkCache cs mapAccumX bracketPush bracketPop = listArray (bounds cs) $ snd $ mapAccumX f [] $ assocs cs where
 f l (i, c) 
 | c == bracketPush = (i : l, Nothing)
 | c == bracketPop = (tail l, Just $ head l)
 | otherwise = (l, Nothing)
cache arr i = case arr ! i of
 Nothing -> error "oops!"
 Just idx -> idx
execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = execCode 0 ts 0 where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 execCode _ _ codePos | codePos == (snd . bounds $ cs) = return ()
 execCode tapePos ts codePos = case cs ! codePos of
 '+' -> updatePos succ
 '-' -> updatePos pred
 '>' -> updateVal succ
 '<' -> updateVal pred
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> putStr [chr $ S.index ts tapePos] >> execNext
 ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
 _ -> execNext
 where
 value = S.index ts tapePos
 nextPos = codePos + 1
 execNext = execCode tapePos ts nextPos
 updatePos f = execCode tapePos (S.update tapePos (f value) ts) nextPos
 updateVal f = execCode (f tapePos) ts nextPos
 branch cond dir = if cond value then execCode tapePos ts (cache dir codePos + 1) else execNext

Here is complete final source:

import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
import Data.List
mkCache cs mapAccumX bracketPush bracketPop = listArray (bounds cs) $ snd $ mapAccumX f [] $ assocs cs where
 f l (i, c) 
 | c == bracketPush = (i : l, Nothing)
 | c == bracketPop = (tail l, Just $ head l)
 | otherwise = (l, Nothing)
cache arr i = case arr ! i of
 Nothing -> error "oops!"
 Just idx -> idx
execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = execCode 0 ts 0 where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 execCode _ _ codePos | codePos == (snd . bounds $ cs) = return ()
 execCode tapePos ts codePos = case cs ! codePos of
 '+' -> updatePos succ
 '-' -> updatePos pred
 '>' -> updateVal succ
 '<' -> updateVal pred
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> putStr [chr $ S.index ts tapePos] >> execNext
 ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
 _ -> execNext
 where
 value = S.index ts tapePos
 nextPos = codePos + 1
 execNext = execCode tapePos ts nextPos
 updatePos f = execCode tapePos (S.update tapePos (f value) ts) nextPos
 updateVal f = execCode (f tapePos) ts nextPos
 branch cond dir = if cond value then execCode tapePos ts (cache dir codePos + 1) else execNext
tape = S.fromList $ replicate 30000 0
csFromString file = listArray (0, length file - 1) file
main = readFile "example.bf" >>= execCode' tape . csFromString

Note that my suggestions about monad-loops, lens and State are still to be applied.

The first step is to declare a datatype for our future state.

data M = M
 { _tapePos :: Int
 , _tape :: S.Seq Int 
 , _codePos :: Int
 }

and make inner execCode accept a single parameter.

 execCode :: M -> IO () 
 execCode (M _ _ codePos) | codePos == (snd . bounds $ cs) = return ()
 execCode (M tapePos ts codePos) = case cs ! codePos of
 '+' -> updatePos succ
 '-' -> updatePos pred
 '>' -> updateVal succ
 '<' -> updateVal pred
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> putStr [chr $ S.index ts tapePos] >> execNext
 ',' -> do { c <- getChar; let newTape = S.update tapePos (ord c) ts in execCode (M tapePos newTape nextPos) }
 _ -> execNext
 where
 value = S.index ts tapePos
 nextPos = codePos + 1
 execNext = execCode (M tapePos ts nextPos)
 updatePos f = execCode (M tapePos (S.update tapePos (f value) ts) nextPos)
 updateVal f = execCode (M (f tapePos) ts nextPos)
 branch cond dir = if cond value then execCode (M tapePos ts (cache dir codePos + 1)) else execNext

M stands for machine state :) and underscores are signals to Data.Lens.TH template Haskell code we will start using a bit later.

We will need a state monad transformer ran on top of IO monad. Let's declare the type of our monad stack:

type ExecT a = StateT M IO a

Our future execCode'' will be of type ExecT () instead of current M -> IO (). To execute it and discard the state (as we do now) we'll use evalStateT:

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode'' (M 0 ts 0) where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 execCode'' :: ExecT ()
 execCode'' = do
 s <- get 
 lift (execCode s)
 execCode :: M -> IO ()
 execCode = ... -- unchanged

Now execCode'' is just a wrapper around our old inner execCode. And we fix execCode so it can be called directly. Note that we should do the following:

• lift all IO
• Replace recursive calls execCode (M ...) with put (M ...) >> execCode
• move where statements around so M tapePos ts codePos is in scope
• replace old termination guard with when

Here is the result:

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 execCode :: ExecT ()
 execCode = do
 M tapePos ts codePos <- get
 let value = S.index ts tapePos
 let nextPos = codePos + 1
 let execNext = put (M tapePos ts nextPos) >> execCode
 let updatePos f = put (M tapePos (S.update tapePos (f value) ts) nextPos) >> execCode 
 let updateVal f = put (M (f tapePos) ts nextPos) >> execCode
 let branch cond dir = if cond value then put (M tapePos ts (cache dir codePos + 1)) >> execCode else execNext
 when (codePos /= (snd . bounds $ cs)) $ case cs ! codePos of
 '+' -> updatePos succ
 '-' -> updatePos pred
 '>' -> updateVal succ
 '<' -> updateVal pred
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> lift (putStr [chr $ S.index ts tapePos]) >> execNext
 ',' -> do { c <- lift getChar; let newTape = S.update tapePos (ord c) ts in put (M tapePos newTape nextPos) >> execCode } 
 _ -> execNext

Now note that all branches of case end in >> execCode. So it can be moved around to form a nice while control structure:

execCode :: ExecT ()
execCode = do
 M tapePos ts codePos <- get
 let value = S.index ts tapePos
 let nextPos = codePos + 1
 let execNext = put (M tapePos ts nextPos)
 let updatePos f = put (M tapePos (S.update tapePos (f value) ts) nextPos) 
 let updateVal f = put (M (f tapePos) ts nextPos)
 let branch cond dir = if cond value then put (M tapePos ts (cache dir codePos + 1)) else execNext
 when (codePos /= (snd . bounds $ cs)) $ do
 case cs ! codePos of
 '+' -> updatePos succ
 '-' -> updatePos pred
 '>' -> updateVal succ
 '<' -> updateVal pred
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> lift (putStr [chr $ S.index ts tapePos]) >> execNext
 ',' -> do { c <- lift getChar; let newTape = S.update tapePos (ord c) ts in put (M tapePos newTape nextPos) } 
 _ -> execNext
 execCode

Now it's finally time for lens to shine.

{-# LANGUAGE TemplateHaskell #-}
import Control.Lens.TH
import Control.Lens
import Control.Applicative
...
data M = M
 { _mTapePos :: Int
 , _mTape :: S.Seq Int 
 , _mCodePos :: Int
 }
$(makeLenses ''M)
type ExecT a = StateT M IO a
execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 execCode :: ExecT ()
 execCode = do
 M tapePos ts codePos <- get
 let value = S.index ts tapePos
 let nextPos = codePos + 1
 let execNext = mCodePos += 1
 let updatePos f = mTape %= S.update tapePos (f value) >> execNext 
 let updateVal f = mTapePos %= f >> execNext
 let branch cond dir = if cond value then mCodePos %= succ . cache dir else execNext
 when (codePos /= (snd . bounds $ cs)) $ do
 case cs ! codePos of
 '+' -> updatePos succ
 '-' -> updatePos pred
 '>' -> updateVal succ
 '<' -> updateVal pred
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> lift (putStr [chr $ S.index ts tapePos]) >> execNext
 ',' -> do { c <- lift getChar; mTape %= S.update tapePos (ord c) >> execNext } 
 _ -> execNext
 execCode

I did the following:

• Added imports and TemplateHaskell pragma
• Added a template Haskell call to generate definitions for mTapePos from _mTapePos
• replaced all put calls with one or many lens-based state modifiers, joined by >>. E.g. if 2 fields of M are modified I chain 2 modifiers. If just 1 - no need to chain. Basically it's just >> execNext instead of nextPos.
• removed unused nextPos

Now it turns out that branch has its own hidden execNext (note succ . in the code above):

let branch cond dir = if cond value then mCodePos %= cache dir >> execNext else execNext

So we can transform it to when easily:

let branch cond dir = when (cond value) (mCodePos %= cache dir) >> execNext

And now it turns out that >> execNext is everywhere. We can move it after case and inline:

execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 execCode :: ExecT ()
 execCode = do
 M tapePos ts codePos <- get
 let value = S.index ts tapePos
 let updatePos f = mTape %= S.update tapePos (f value) 
 let updateVal f = mTapePos %= f
 let branch cond dir = when (cond value) (mCodePos %= cache dir)
 when (codePos /= (snd . bounds $ cs)) $ do
 case cs ! codePos of
 '+' -> updatePos succ
 '-' -> updatePos pred
 '>' -> updateVal succ
 '<' -> updateVal pred
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> lift (putStr [chr $ S.index ts tapePos])
 ',' -> do { c <- lift getChar; mTape %= S.update tapePos (ord c) } 
 _ -> return ()
 mCodePos += 1
 execCode

After some more cleanup we get:

{-# LANGUAGE TemplateHaskell #-}
import Control.Lens.TH
import Control.Lens
import Control.Applicative
import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
import Data.List
import Control.Monad.State
mkCache cs mapAccumX bracketPush bracketPop = listArray (bounds cs) $ snd $ mapAccumX f [] $ assocs cs where
 f l (i, c) 
 | c == bracketPush = (i : l, Nothing)
 | c == bracketPop = (tail l, Just $ head l)
 | otherwise = (l, Nothing)
cache arr i = case arr ! i of
 Nothing -> error "oops!"
 Just idx -> idx
data M = M
 { _mTapePos :: Int
 , _mTape :: S.Seq Int 
 , _mCodePos :: Int
 }
$(makeLenses ''M)
type ExecT a = StateT M IO a
execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 execCode :: ExecT ()
 execCode = do
 M tapePos ts codePos <- get
 let value = S.index ts tapePos
 let tapeAtPos = mTape . ix tapePos
 let branch cond dir = when (cond value) (mCodePos %= cache dir)
 when (codePos /= (snd . bounds $ cs)) $ do
 case cs ! codePos of
 '+' -> tapeAtPos += 1 
 '-' -> tapeAtPos -= 1
 '>' -> mTapePos += 1
 '<' -> mTapePos -= 1
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> lift (putChar $ chr value)
 ',' -> do { c <- lift getChar; mTape %= S.update tapePos (ord c) } 
 _ -> return ()
 mCodePos += 1
 execCode
tape = S.fromList $ replicate 30000 0
csFromString file = listArray (0, length file - 1) file
main = readFile "example.bf" >>= execCode' tape . csFromString

One more iteration of tuning for execCode' to make code more uniform which is good for readability and maintenance:

• tapeAtPos is made a self-contained compound lens, without reliance on tapePos and
• tapeAtPos is moved out of execState' body to global scope, and renamed to mTapeAtPos uniformly with other lenses
• value is renamed tapeAtPos as it corresponds to mTapeAtPos
• mTapeAtPos is used uniformly for both getting and updating the value everywhere including the getChar branch
• unsafeUse helper is used to get tapeAtPos uniformly with codePos. It is called unsafe because tapeAtPos may fail if mTapePos is out of range!
• lens API is used to read code uniformly with reading tape
• extra parenthesis/$ are removed from when condition
• M ... <- get is removed as it is not used anymore

The code:

mTapeAtPos f m = (mTape . ix (m ^. mTapePos)) f m
unsafeUse traversal = (^?! traversal) <$> get
execCode' :: S.Seq Int -> Array Int Char -> IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 execCode :: ExecT ()
 execCode = do
 tapeAtPos <- unsafeUse mTapeAtPos 
 codePos <- use mCodePos
 let branch cond dir = when (cond tapeAtPos) (mCodePos %= cache dir)
 when (codePos /= snd (bounds cs)) $ do
 case cs ^?! ix codePos of
 '+' -> mTapeAtPos += 1 
 '-' -> mTapeAtPos -= 1
 '>' -> mTapePos += 1
 '<' -> mTapePos -= 1
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> lift (putChar $ chr tapeAtPos)
 ',' -> do { c <- lift getChar; mTapeAtPos .= ord c } 
 _ -> return ()
 mCodePos += 1
 execCode

It can be made even more uniform:

• at this point tapePos is used only in branch it can be moved into branch
• branch then can be moved outside of execCode as it doesn't a closure any more
• it seems inner execCode is better named loop, and ExecT is LoopStateT

The code:

branch cond dir = do 
 tapeAtPos <- unsafeUse mTapeAtPos 
 when (cond tapeAtPos) (mCodePos %= cache dir)
execCode :: S.Seq Int -> Array Int Char -> IO ()
execCode ts cs = evalStateT loop (M 0 ts 0) where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 loop :: LoopStateT ()
 loop = do
 codePos <- use mCodePos
 when (codePos /= snd (bounds cs)) $ do
 case cs ^?! ix codePos of
 '+' -> mTapeAtPos += 1 
 '-' -> mTapeAtPos -= 1
 '>' -> mTapePos += 1
 '<' -> mTapePos -= 1
 '[' -> branch (== 0) next 
 ']' -> branch (/= 0) prev
 '.' -> unsafeUse mTapePos >>= lift . putChar . chr
 ',' -> lift (ord <$> getChar) >>= (mTapeAtPos .=)
 _ -> return ()
 mCodePos += 1
 loop

At this point it seems branch and ./, symmetry aren't worth it, so I inlined branch, reverted getChar branch to use do-notation and moved tapeAtPos <- to the top of loop:

 loop :: LoopStateT ()
 loop = do
 tapeAtPos <- unsafeUse mTapeAtPos
 codePos <- use mCodePos
 when (codePos /= snd (bounds cs)) $ do
 case cs ^?! ix codePos of
 '+' -> mTapeAtPos += 1 
 '-' -> mTapeAtPos -= 1
 '>' -> mTapePos += 1
 '<' -> mTapePos -= 1
 '[' -> when (tapeAtPos == 0) (mCodePos %= cache next)
 ']' -> when (tapeAtPos /= 0) (mCodePos %= cache prev)
 '.' -> lift $ putChar (chr tapeAtPos)
 ',' -> do { c <- lift getChar; mTapeAtPos .= ord c }
 _ -> return ()
 mCodePos += 1
 loop

Another improvement is better diagnostics of match failures in cache:

cache arr i = case arr ! i of
 Nothing -> error $ "No matching bracket at offset " ++ show i
 Just idx -> idx

So we get:

{-# LANGUAGE TemplateHaskell #-}
import Control.Lens.TH
import Control.Lens
import Control.Applicative
import qualified Data.Sequence as S
import Data.Char (chr, ord)
import Data.Array
import Data.List (mapAccumR, mapAccumL)
import Control.Monad.State (lift, get, evalStateT, when, StateT(..))
mkCache cs mapAccumX bracketPush bracketPop = listArray (bounds cs) $ snd $ mapAccumX f [] $ assocs cs where
 f l (i, c) 
 | c == bracketPush = (i : l, Nothing)
 | c == bracketPop = (tail l, Just $ head l)
 | otherwise = (l, Nothing)
cache arr i = case arr ! i of
 Nothing -> error $ "No matching bracket at offset " ++ show i
 Just idx -> idx
data M = M
 { _mTapePos :: Int
 , _mTape :: S.Seq Int 
 , _mCodePos :: Int
 }
$(makeLenses ''M)
type LoopStateT a = StateT M IO a
mTapeAtPos f m = (mTape . ix (m ^. mTapePos)) f m
unsafeUse traversal = (^?! traversal) <$> get
execCode :: S.Seq Int -> Array Int Char -> IO ()
execCode ts cs = evalStateT loop (M 0 ts 0) where
 prev = mkCache cs mapAccumL '[' ']'
 next = mkCache cs mapAccumR ']' '['
 loop :: LoopStateT ()
 loop = do
 tapeAtPos <- unsafeUse mTapeAtPos
 codePos <- use mCodePos
 when (codePos /= snd (bounds cs)) $ do
 case cs ^?! ix codePos of
 '+' -> mTapeAtPos += 1 
 '-' -> mTapeAtPos -= 1
 '>' -> mTapePos += 1
 '<' -> mTapePos -= 1
 '[' -> when (tapeAtPos == 0) (mCodePos %= cache next)
 ']' -> when (tapeAtPos /= 0) (mCodePos %= cache prev)
 '.' -> lift $ putChar $ chr tapeAtPos
 ',' -> do { c <- lift getChar; mTapeAtPos .= ord c }
 _ -> return ()
 mCodePos += 1
 loop
tape = S.fromList $ replicate 30000 0
csFromString file = listArray (0, length file - 1) file
main = readFile "example.bf" >>= execCode tape . csFromString

• John Smith: Hey I just realized you replied to this because I had break from school. I think I lost the original account I posted this under. I just wanted to thank you for such a long and comprehensive reply. A lot of it is over my head but I will continue to reference this for years probably while I learn Haskell further.

Answer 2

I'm not convinced that this interpreter works, having tried it on two ASCII table printers and a FizzBuzz, and finding that both failed to loop at all. Hello World! worked, though.

For one thing, it appears that execCode terminates prematurely: it ends before executing the last instruction in the program, not after.

Brainfuck typically has a tape whose values wrap modulo 256 (though there are also dialects with larger cells). Your cell size is just the range of the Haskell Int type, which is guaranteed to hold at least -2²⁹ ≤ Int ≤ 2²⁹ - 1, but may have a larger range. Those bounds don't guarantee to any of the common Brainfuck cell sizes.

• John Smith: Thanks for the reply! Made some changes and those two examples seem to work now. Let me know if there's anything else. Conway's game of life seems to work too after checking.
• 200_success: What you may and may not do after receiving answers. I've rolled back your edit.
• John Smith: Isn't it a waste of time to have multiple people suggest the same thing and spot the same errors? All I need to change is an == to > to make those two listed programs work.
• 200_success: Future reviewers would probably read existing answers before writing an answer. On the other hand, fixing the code in the question in response to an answer invalidates the answer. It's like asking for help, then saying "never mind, I fixed it."
• 200_success: @nponeccop As noted on the Meta post, in our experience, allowing edits, addenda, and errata in questions leads to confusion about what code is to be reviewed.