Brainfuck interpreter written in Haskell

bfi.hs

import qualified Control.Monad.State as S
import           Data.Char           (chr)
import           Data.Maybe          (maybe)
import           Data.Word           (Word8)

newtype Zipper a = Zipper {getZipper :: ([a], a, [a])}
  deriving (Show)

toZipper :: [a] -> Zipper a
toZipper (x : xs) = Zipper ([], x, xs)

current :: Zipper a -> a
current (Zipper (_, x, _)) = x

modify :: (a -> a) -> Zipper a -> Zipper a
modify f (Zipper (l, x, r)) = Zipper (l, f x, r)

goR :: Zipper a -> Zipper a
goR (Zipper (l, x, y : r)) = Zipper (x : l, y, r)

goL :: Zipper a -> Zipper a
goL (Zipper (y : l, x, r)) = Zipper (l, y, x : r)

--

data Opcode = GoR | GoL | Inc | Dec | Put | Get | Jump | Back | End
  deriving (Eq, Show)

data Machine = Machine
  { program :: Zipper Opcode
  , input   :: [Word8]
  , tape    :: Zipper Word8
  } deriving (Show)

parse :: String -> [Opcode]
parse ""        = [End]
parse ('>' : s) = GoR  : parse s
parse ('<' : s) = GoL  : parse s
parse ('+' : s) = Inc  : parse s
parse ('-' : s) = Dec  : parse s
parse ('.' : s) = Put  : parse s
parse (',' : s) = Get  : parse s
parse ('[' : s) = Jump : parse s
parse (']' : s) = Back : parse s

run :: [Opcode] -> [Word8] -> [Word8]
run program input = S.evalState nextHalted $ machine program input

machine :: [Opcode] -> [Word8] -> Machine
machine program input = Machine
  { program = toZipper program
  , input   = input
  , tape    = toZipper $ repeat 0
  }

isHalted :: Machine -> Bool
isHalted = (== End) . current . program

nextHalted :: S.State Machine [Word8]
nextHalted = do
  m <- S.get
  if isHalted m then return [] else do
    c <- next
    s <- nextHalted
    return $ maybe s (: s) c

next :: S.State Machine (Maybe Word8)
next = do
  m <- S.get
  let m' = m {program = goR $ program m}
  let op = current (program m)
  S.put $ case op of
    GoR  -> m' {tape = goR $ tape m}
    GoL  -> m' {tape = goL $ tape m}
    Inc  -> m' {tape = modify (+ 1) $ tape m}
    Dec  -> m' {tape = modify (subtract 1) $ tape m}
    Put  -> m'
    Get  -> let c : s = input m in m' {input = s, tape = modify (const c) $ tape m}
    Jump
      | current (tape m) == 0 -> m {program = jump $ program m}
      | otherwise             -> m'
    Back -> m {program = back $ program m}
    End  -> m
  return $ case op of
    Put  -> Just . current $ tape m
    _    -> Nothing

jump :: Zipper Opcode -> Zipper Opcode
jump = go 0 . goR
  where
    go d z = case current z of
      Jump -> go (d + 1) z'
      Back -> case compare d 0 of
        EQ -> z'
        GT -> go (d - 1) z'
      _ -> go d z'
      where
        z' = goR z

back :: Zipper Opcode -> Zipper Opcode
back = go 0 . goL
  where
    go d z = case current z of
      Back -> go (d + 1) z'
      Jump -> case compare d 0 of
        EQ -> z
        GT -> go (d - 1) z'
      _ -> go d z'
      where
        z' = goL z

--

code :: String
code = ">+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++\
  \++>-]<.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>\
  \++++++++[<++++>-]<+.[-]++++++++++."

main :: IO ()
main = putStr . map (chr . fromIntegral) . flip run [] . parse $ code