Brainfuck interpreter with handcrafted lenses. Catamorphism not included though :<

kata_brainfuck.hs

{-# LANGUAGE RankNTypes, RecordWildCards #-}
import Data.Char
import Data.Functor.Identity
import Control.Applicative

{-
Inspired from real-world Brainf**k, we want to create an interpreter of that language which will
support the following instructions (the machine memory or 'data' should behave like a potentially
infinite array of bytes, initialized to 0):

> increment the data pointer (to point to the next cell to the right).
< decrement the data pointer (to point to the next cell to the left).
+ increment (increase by one, truncate overflow: 255 + 1 = 0) the byte at the data pointer.
- decrement (decrease by one, treat as unsigned byte: 0 - 1 = 255 ) the byte at the data pointer.
. output the byte at the data pointer.
, accept one byte of input, storing its value in the byte at the data pointer.
[ if the byte at the data pointer is zero, then instead of moving the instruction pointer forward to
  the next command, jump it forward to the command after the matching ] command.
] if the byte at the data pointer is nonzero, then instead of moving the instruction pointer forward
  to the next command, jump it back to the command after the matching [ command.

The function will take in input...
  * the program code, a string with the sequence of machine instructions,
  * the program input, a string, eventually empty, that will be interpreted as an array of bytes
    using each character's ASCII code and will be consumed by the , instruction

... and will return ...
  * the output of the interpreted code (always as a string), produced by the . instruction.
-}

type Commands = String
type Input    = String
type Output   = String

executeString :: Commands -> Input -> Maybe Output
executeString source input = exec universeZero source input
  where universeZero = U{..}
        left   = [0, 0..]
        right  = [0, 0..]
        cell   = 0
        stack  = []
        output = ""


data U = U  { left   :: [Int]
            , cell   :: Int
            , right  :: [Int]
            , stack  :: [String]
            , output :: String
            } deriving (Show)

-- I've gone lazy & a bit crazy.
type ULens' b = Functor f => (b -> f b) -> U -> f U

uLeft, uRight :: ULens' [Int]
uLeft  f u = fmap (\l' -> u{left=l'})  $ f.left  $ u
uRight f u = fmap (\r' -> u{right=r'}) $ f.right $ u

uCell :: ULens' Int
uCell f u = fmap (\c' -> u{cell=(c' `mod` 256)}) $ f.cell $ u

uOut :: ULens' Output
uOut f u = fmap (\o' -> u{output=o'}) $ f.output $ u

set :: ULens' a -> a -> U -> U
set lns v u = runIdentity $ lns (Identity . const v) u

over :: ULens' a -> (a -> a) -> U -> U
over lns f u = runIdentity $ lns (Identity . f) u



exec :: U -> Commands -> Input -> Maybe Output
exec u []       _      = Just . reverse . output $ u
exec u ('[':cs) is     = extractLoop cs >>= withLoop
  where withLoop (l,rest) | cell u == 0 = exec u rest is
                          | otherwise   = exec u{ stack=l:stack u } cs is
exec u (']':cs) is     = case stack u of
                          []                   -> Nothing
                          (h:hs) | cell u == 0 -> exec u{stack=hs} cs      is
                                 | otherwise   -> exec u           (h++cs) is
exec u ('>':cs) is     = exec u{left=c:ls, cell=r, right=rs} cs is
  where U ls c (r:rs) _ _ = u
exec u ('<':cs) is     = exec u{left=ls, cell=l, right=c:rs} cs is
  where U (l:ls) c rs _ _ = u
exec u ('+':cs) is     = exec (over uCell (+1)             u) cs is
exec u ('-':cs) is     = exec (over uCell (subtract 1)     u) cs is
exec u ('.':cs) is     = exec (over uOut  ((chr.cell$ u):) u) cs is
exec u (',':cs) []     = Nothing
exec u (',':cs) (i:is) = exec (set  uCell (ord i)          u) cs is


extractLoop :: Commands -> Maybe (Commands, Commands)
extractLoop = go 0 ""
  where go n res rest | n < 0 = Just (reverse res, rest)
        go _ _ [] = Nothing
        go n res (c:cs) = go (nf c) (c:res) cs
          where nf ']' = n - 1
                nf '[' = n + 1
                nf _   = n