blog

Haskell is a wonderfully abstract language, with a community that backs it up - many of the most successful libraries are based on relatively recent papers that heavily incorporate algebra and category theory.

As such, you can also do some very abstract things, and you can write code that is difficult to understand, which is precisely what we're going to do here. Brainfuck is already an intentionally esoteric language; we're going to write an interpreter that's as laconic as possible, bringing in lenses, recursion schemes, monad transformers, and monadic parser combinators, hopefully learning something along the way.

Here's the core code (omitting imports + command-line parser):

type St a = StateT IndexArr IO a
type IndexArr = (V.Vector Int, Int)
-- | Syntax tree for brainfuck
data Syntax a = Loop (Syntax a)
              | Seq [Syntax a]
              | Token a deriving (Show)
makeBaseFunctor ''Syntax
-- | Map a char to its action in the St monad
toAction :: Char -> St ()
toAction = maybe (error mempty) id . flip M.lookup keys
    where modifyVal f = flip modifyByIndex f . snd =<< get 
          modifyByIndex i = modifyState (_1 . sliced i 1 . forced) . fmap
          modifyState lens = (lens %%=) . (pure .)
          readChar = get >>= ((_,i) -> modifyByIndex i . const =<< (liftIO . (fmap fromEnum)) getChar)
          displayChar = get >>= ((arr,i) -> liftIO . putChar . toEnum . (V.! i) $ arr)
          keys = M.fromList [ ('.', displayChar)
                            , (',', readChar)
                            , ('+', modifyVal (+1))
                            , ('-', modifyVal (subtract 1))
                            , ('>', modifyState _2 (+1))
                            , ('<', modifyState _2 (subtract 1)) ]
-- | Parse to syntax tree
brainheck :: Parser (Syntax Char)
brainheck = Seq <$> many (Seq . (fmap Token) <$> (some . oneOf) "+-.,<>"
    <|> Loop <$> between (char '[') (char ']') brainheck)
algebra :: Base (Syntax Char) (St ()) -> St ()
algebra (TokenF x) = toAction x
algebra (SeqF x) = foldr (>>) (pure ()) x
algebra l@(LoopF x) = check >>= (\bool -> if bool then pure () else x >> algebra l)
    where check = get >>= ((arr,i) -> pure . (==0) . (V.! i) $ arr)
-- | Evaluate syntax tree
run :: (Syntax Char) -> IO ()
run parsed = fst <$> runStateT (cata algebra parsed) (V.replicate 30000 0, 0)
-- | Parse and return an error or a syntax tree
parseBrainheck :: FilePath -> T.Text -> Either (ParseError (Token T.Text) Dec) (Syntax Char)
parseBrainheck filepath = (parse (brainheck) filepath) . (T.filter (elem "[]+-.,<>"))

The full code is available in the brainheck package, or via github.

We start off with a monad transformer, giving us St a as our underlying monad: this allows us to keep a global state and perform IO and have it all end up in the right order without too much worry.

type St a = StateT IndexArr IO a
type IndexArr = (V.Vector Int, Int)

Brainfuck demands a 30000-cell array initialized to zero, so our state will be a boxed (i.e., fixed-size) vector of Ints, but an Int to index it (like a pointer).

Next is our syntax tree, for which we use an Algebraic Data Type (ADT) - the "morally correct" way to parse syntax, though in this case we only have three constructors: Loop (Syntax a), which means we process the contents until we escape the loop, Seq [Syntax a], corresponding to a sequence of actions, and Token a, corresponding to an action.

data Syntax a = Loop (Syntax a)
              | Seq [Syntax a]
              | Token a deriving (Show)

Note that this is parametrized by an underlying type, which might seem like overkill. But, by making it functorial, we will get the full advantages of recursion schemes later on!

With our data type set, we can think about parsing. Brainfuck is simple enough that we only need an applicative parser plus combinators. It ends up being a one-liner if we take advantage of recursion:

brainheck :: Parser (Syntax Char)
brainheck = Seq <$> many (Seq . (fmap Token) <$> (some . oneOf) "+-.,<>"
    <|> Loop <$> between (char '[') (char ']') brainheck)

Now we need turn to the tree of characters into something useful - i.e. the IO that the user should see when they run your program. Each character corresponds to a particular action in the St monad (brainfuck is not very complicated), so we start with a function toChar :: Char -> St () to do just that:

toAction = maybe (error mempty) id . flip M.lookup keys
    where modifyVal f = flip modifyByIndex f . snd =<< get 
          modifyByIndex i = modifyState (_1 . sliced i 1 . forced) . fmap
          modifyState lens = (lens %%=) . (pure .)
          readChar = get >>= ((_,i) -> modifyByIndex i . const =<< (liftIO . (fmap fromEnum)) getChar)
          displayChar = get >>= ((arr,i) -> liftIO . putChar . toEnum . (V.! i) $ arr)
          keys = M.fromList [ ('.', displayChar)
                            , (',', readChar)
                            , ('+', modifyVal (+1))
                            , ('-', modifyVal (subtract 1))
                            , ('>', modifyState _2 (+1))
                            , ('<', modifyState _2 (subtract 1)) ]

The meat of this is M.lookup, which basically says "turn a list of tuples into a function" - keys being the list of tuples. This will return an error type if we try to feed it any other Char, but we've already filtered those out since they have no effect in brainfuck.

modifyVal and modifyState each take a lens looking into our underlying state and use that to modify the state. %%= is an infix function that basically just allows lenses to be applied to the underlying state rather than the value passed into the function. Also note the use of sliced i 1 (a lens looking into our underlying array) and forced, a lens which forces the operations to be performed with copying (increasing speed).

But of course, our program is not a Char, nor is it even a list of Chars: our parser returns a Syntax Char, so we're going to need something to evaluate it. We could use pattern matching and recursion, but there's a more general (and sometimes faster) way: recursion schemes!

algebra :: Base (Syntax Char) (St ()) -> St ()
algebra (TokenF x) = toAction x
algebra (SeqF x) = foldr (>>) (pure ()) x
algebra l@(LoopF x) = check >>= (\bool -> if bool then pure () else x >> algebra l)
    where check = get >>= ((arr,i) -> pure . (==0) . (V.! i) $ arr)
-- | Evaluate syntax tree
run :: (Syntax Char) -> IO ()
run parsed = fst <$> runStateT (cata algebra parsed) (V.replicate 30000 0, 0)

The first function is our (Base t)-algebra, and the second is the actual catamorphism. Because of our earlier

makeBaseFunctor ''Syntax

we don't have to do anything fancy in terms of checking exactly what can be folded or not - we can define all our behavior on a SeqF x by treating it like a list of St ()s, and we can similarly define our behavior on a LoopF x by treating x like an St () - check is in fact just our function to check, in the St monad, whether we enter the loop again (in brainfuck, loops are entered only when the value at the pointer is nonzero).

And that's basically it. parseBrainheck is now a function accepting text (i.e. your program) as input. Of course, you probably want to wrap it with something nicer to read from a file, say, but as it stands, 42 lines + imports to get a Turing-Complete language really isn't that bad!