Brainfuck interpreter in Haskell 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 -&gt; Bracket Index
prevBracketIndex :: Int -&gt; Int -&gt; Array Int Char -&gt; 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 -&gt; Int -&gt; Array Int Char -&gt; 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 -&gt; S.Seq Int -&gt; Int -&gt; Array Int Char -&gt; 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 == '&gt;' = execCode (tapePos + 1) ts nextPos cs
    | cmd == '&lt;' = execCode (tapePos - 1) ts nextPos cs
    | cmd == '[' &amp;&amp; value == 0 = execCode tapePos ts (nextBracketIndex codePos 0 cs + 1) cs
    | cmd == ']' &amp;&amp; value /= 0 = execCode tapePos ts (prevBracketIndex codePos 0 cs + 1) cs
    | cmd == '.' = putStr [chr $ S.index ts tapePos] &gt;&gt; execCode tapePos ts nextPos cs
    | cmd == ',' = do { c &lt;- 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 &lt;- readFile "example.bf"
    execCode 0 tape 0 (listArray (0, length file - 1) file)
Use case instead of == and guards everywhere:

prevBracketIndex :: Int -&gt; Int -&gt; Array Int Char -&gt; Int
prevBracketIndex i depth cs = case cs ! i of
    '[' -&gt; if (depth - 1) == 0 then i else prevBracketIndex (i - 1) (depth - 1) cs
    ']' -&gt; prevBracketIndex (i - 1) (depth + 1) cs
    _ -&gt; 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 -&gt; Array Int Char -&gt; Int
prevBracketIndex i cs = pbi i 0 where
    pbi i depth = case cs ! i of
        '[' -&gt; if (depth - 1) == 0 then i else pbi (i - 1) (depth - 1)
        ']' -&gt; pbi (i - 1) (depth + 1)
        _ -&gt; 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
        '[' -&gt; (i : l, Nothing)
        ']' -&gt; (tail l, Just $ head l)
        _ -&gt; (l, Nothing)

cacheNext cs = listArray (bounds cs) $ snd $ mapAccumR f [] $ assocs cs where
    f l (i, c) = case c of
        ']' -&gt; (i : l, Nothing)
        '[' -&gt; (tail l, Just $ head l)
        _ -&gt; (l, Just i)

cache arr i = case arr ! i of
    Nothing -&gt; error "oops!"
    Just idx -&gt; idx

execCode' :: S.Seq Int -&gt; Array Int Char -&gt; 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 == '&gt;' = execCode (tapePos + 1) ts nextPos
        | cmd == '&lt;' = execCode (tapePos - 1) ts nextPos
        | cmd == '[' &amp;&amp; value == 0 = execCode tapePos ts (cache next codePos + 1)
        | cmd == ']' &amp;&amp; value /= 0 = execCode tapePos ts (cache prev codePos + 1)
        | cmd == '.' = putStr [chr $ S.index ts tapePos] &gt;&gt; execCode tapePos ts nextPos
        | cmd == ',' = do { c &lt;- 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" &gt;&gt;= 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
    '+' -&gt; execCode tapePos (S.update tapePos (value + 1) ts) nextPos
    '-' -&gt; execCode tapePos (S.update tapePos (value - 1) ts) nextPos
    '&gt;' -&gt; execCode (tapePos + 1) ts nextPos
    '&lt;' -&gt; execCode (tapePos - 1) ts nextPos
    '[' -&gt; if value == 0 then execCode tapePos ts (cache next codePos + 1) else execNext 
    ']' -&gt; if value /= 0 then execCode tapePos ts (cache prev codePos + 1) else execNext
    '.' -&gt; putStr [chr $ S.index ts tapePos] &gt;&gt; execNext
    ',' -&gt; do { c &lt;- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
    _ -&gt; 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
    '+' -&gt; updatePos succ
    '-' -&gt; updatePos pred
    '&gt;' -&gt; updateVal succ
    '&lt;' -&gt; updateVal pred
    '[' -&gt; branch (== 0) next 
    ']' -&gt; branch (/= 0) prev
    '.' -&gt; putStr [chr $ S.index ts tapePos] &gt;&gt; execNext
    ',' -&gt; do { c &lt;- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
    _ -&gt; 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 -&gt; error "oops!"
    Just idx -&gt; idx

execCode' :: S.Seq Int -&gt; Array Int Char -&gt; 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
        '+' -&gt; updatePos succ
        '-' -&gt; updatePos pred
        '&gt;' -&gt; updateVal succ
        '&lt;' -&gt; updateVal pred
        '[' -&gt; branch (== 0) next 
        ']' -&gt; branch (/= 0) prev
        '.' -&gt; putStr [chr $ S.index ts tapePos] &gt;&gt; execNext
        ',' -&gt; do { c &lt;- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
        _ -&gt; 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 -&gt; error "oops!"
    Just idx -&gt; idx

execCode' :: S.Seq Int -&gt; Array Int Char -&gt; 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
        '+' -&gt; updatePos succ
        '-' -&gt; updatePos pred
        '&gt;' -&gt; updateVal succ
        '&lt;' -&gt; updateVal pred
        '[' -&gt; branch (== 0) next 
        ']' -&gt; branch (/= 0) prev
        '.' -&gt; putStr [chr $ S.index ts tapePos] &gt;&gt; execNext
        ',' -&gt; do { c &lt;- getChar; let newTape = S.update tapePos (ord c) ts in execCode tapePos newTape nextPos }
        _ -&gt; 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" &gt;&gt;= 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 -&gt; IO ()      
    execCode (M _ _ codePos) | codePos == (snd . bounds $ cs) = return ()
    execCode (M tapePos ts codePos) = case cs ! codePos of
        '+' -&gt; updatePos succ
        '-' -&gt; updatePos pred
        '&gt;' -&gt; updateVal succ
        '&lt;' -&gt; updateVal pred
        '[' -&gt; branch (== 0) next 
        ']' -&gt; branch (/= 0) prev
        '.' -&gt; putStr [chr $ S.index ts tapePos] &gt;&gt; execNext
        ',' -&gt; do { c &lt;- getChar; let newTape = S.update tapePos (ord c) ts in execCode (M tapePos newTape nextPos) }
        _ -&gt; 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 -&gt; IO (). To execute it and discard the state (as we do now) we'll use evalStateT:

execCode' :: S.Seq Int -&gt; Array Int Char -&gt; IO ()
execCode' ts cs = evalStateT execCode'' (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode'' :: ExecT ()
    execCode'' = do
        s &lt;- get 
        lift (execCode s)

    execCode :: M -&gt; 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 ...) &gt;&gt; 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 -&gt; Array Int Char -&gt; 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 &lt;- get
        let value = S.index ts tapePos
        let nextPos = codePos + 1
        let execNext = put (M tapePos ts nextPos) &gt;&gt; execCode
        let updatePos f = put (M tapePos (S.update tapePos (f value) ts) nextPos) &gt;&gt; execCode 
        let updateVal f = put (M (f tapePos) ts nextPos) &gt;&gt; execCode
        let branch cond dir = if cond value then put (M tapePos ts (cache dir codePos + 1)) &gt;&gt; execCode else execNext

        when (codePos /= (snd . bounds $ cs)) $ case cs ! codePos of
            '+' -&gt; updatePos succ
            '-' -&gt; updatePos pred
            '&gt;' -&gt; updateVal succ
            '&lt;' -&gt; updateVal pred
            '[' -&gt; branch (== 0) next 
            ']' -&gt; branch (/= 0) prev
            '.' -&gt; lift (putStr [chr $ S.index ts tapePos]) &gt;&gt; execNext
            ',' -&gt; do { c &lt;- lift getChar; let newTape = S.update tapePos (ord c) ts in put (M tapePos newTape nextPos) &gt;&gt; execCode } 
            _ -&gt; execNext


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

execCode :: ExecT ()
execCode = do
    M tapePos ts codePos &lt;- 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
            '+' -&gt; updatePos succ
            '-' -&gt; updatePos pred
            '&gt;' -&gt; updateVal succ
            '&lt;' -&gt; updateVal pred
            '[' -&gt; branch (== 0) next 
            ']' -&gt; branch (/= 0) prev
            '.' -&gt; lift (putStr [chr $ S.index ts tapePos]) &gt;&gt; execNext
            ',' -&gt; do { c &lt;- lift getChar; let newTape = S.update tapePos (ord c) ts in put (M tapePos newTape nextPos) } 
            _ -&gt; 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 -&gt; Array Int Char -&gt; 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 &lt;- get
        let value = S.index ts tapePos
        let nextPos = codePos + 1
        let execNext = mCodePos += 1
        let updatePos f = mTape %= S.update tapePos (f value) &gt;&gt; execNext 
        let updateVal f = mTapePos %= f &gt;&gt; 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
                '+' -&gt; updatePos succ
                '-' -&gt; updatePos pred
                '&gt;' -&gt; updateVal succ
                '&lt;' -&gt; updateVal pred
                '[' -&gt; branch (== 0) next 
                ']' -&gt; branch (/= 0) prev
                '.' -&gt; lift (putStr [chr $ S.index ts tapePos]) &gt;&gt; execNext
                ',' -&gt; do { c &lt;- lift getChar; mTape %= S.update tapePos (ord c) &gt;&gt; execNext } 
                _ -&gt; 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 &gt;&gt;. E.g. if 2 fields of M are modified I chain 2 modifiers. If just 1 - no need to chain. Basically it's just &gt;&gt; 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 &gt;&gt; execNext else execNext


So we can transform it to when easily:

let branch cond dir = when (cond value) (mCodePos %= cache dir) &gt;&gt; execNext


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

execCode' :: S.Seq Int -&gt; Array Int Char -&gt; 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 &lt;- 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
                '+' -&gt; updatePos succ
                '-' -&gt; updatePos pred
                '&gt;' -&gt; updateVal succ
                '&lt;' -&gt; updateVal pred
                '[' -&gt; branch (== 0) next 
                ']' -&gt; branch (/= 0) prev
                '.' -&gt; lift (putStr [chr $ S.index ts tapePos])
                ',' -&gt; do { c &lt;- lift getChar; mTape %= S.update tapePos (ord c) } 
                _ -&gt; 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 -&gt; error "oops!"
    Just idx -&gt; 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 -&gt; Array Int Char -&gt; 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 &lt;- 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
                '+' -&gt; tapeAtPos += 1 
                '-' -&gt; tapeAtPos -= 1
                '&gt;' -&gt; mTapePos += 1
                '&lt;' -&gt; mTapePos -= 1
                '[' -&gt; branch (== 0) next 
                ']' -&gt; branch (/= 0) prev
                '.' -&gt; lift (putChar $ chr value)
                ',' -&gt; do { c &lt;- lift getChar; mTape %= S.update tapePos (ord c) } 
                _ -&gt; return ()
            mCodePos += 1
            execCode

tape = S.fromList $ replicate 30000 0

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

main = readFile "example.bf" &gt;&gt;= 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 ... &lt;- get is removed as it is not used anymore


The code:

mTapeAtPos f m = (mTape . ix (m ^. mTapePos)) f m

unsafeUse traversal = (^?! traversal) &lt;$&gt; get

execCode' :: S.Seq Int -&gt; Array Int Char -&gt; IO ()
execCode' ts cs = evalStateT execCode (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

    execCode :: ExecT ()
    execCode = do
        tapeAtPos &lt;- unsafeUse mTapeAtPos 
        codePos &lt;- use mCodePos
        let branch cond dir = when (cond tapeAtPos) (mCodePos %= cache dir)
        when (codePos /= snd (bounds cs)) $ do
            case cs ^?! ix codePos of
                '+' -&gt; mTapeAtPos += 1 
                '-' -&gt; mTapeAtPos -= 1
                '&gt;' -&gt; mTapePos += 1
                '&lt;' -&gt; mTapePos -= 1
                '[' -&gt; branch (== 0) next 
                ']' -&gt; branch (/= 0) prev
                '.' -&gt; lift (putChar $ chr tapeAtPos)
                ',' -&gt; do { c &lt;- lift getChar; mTapeAtPos .= ord c } 
                _ -&gt; 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 &lt;- unsafeUse mTapeAtPos 
    when (cond tapeAtPos) (mCodePos %= cache dir)

execCode :: S.Seq Int -&gt; Array Int Char -&gt; IO ()
execCode ts cs = evalStateT loop (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['



    loop :: LoopStateT ()
    loop = do
        codePos &lt;- use mCodePos
        when (codePos /= snd (bounds cs)) $ do
            case cs ^?! ix codePos of
                '+' -&gt; mTapeAtPos += 1 
                '-' -&gt; mTapeAtPos -= 1
                '&gt;' -&gt; mTapePos += 1
                '&lt;' -&gt; mTapePos -= 1
                '[' -&gt; branch (== 0) next 
                ']' -&gt; branch (/= 0) prev
                '.' -&gt; unsafeUse mTapePos &gt;&gt;= lift . putChar . chr
                ',' -&gt; lift (ord &lt;$&gt; getChar) &gt;&gt;= (mTapeAtPos .=)
                _ -&gt; 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 &lt;- to the top of loop:

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


Another improvement is better diagnostics of match failures in cache:

cache arr i = case arr ! i of
    Nothing -&gt; error $ "No matching bracket at offset " ++ show i
    Just idx -&gt; 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 -&gt; error $ "No matching bracket at offset " ++ show i
    Just idx -&gt; 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) &lt;$&gt; get

execCode :: S.Seq Int -&gt; Array Int Char -&gt; IO ()
execCode ts cs = evalStateT loop (M 0 ts 0) where
    prev = mkCache cs mapAccumL '[' ']'
    next = mkCache cs mapAccumR ']' '['

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

tape = S.fromList $ replicate 30000 0

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

main = readFile "example.bf" &gt;&gt;= execCode tape . csFromString