A haskell brainf**k solver (largely referred to niklasb/haskell-brainfuck)

bfsolver.hs

-- A simple brainfuck solver
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.State
import Data.Char (ord, chr)
import Data.Word
import Control.Applicative hiding ((<|>), many)
import Text.ParserCombinators.Parsec

data BFInst = Next
            | Prev
            | Inc
            | Dec
            | Input
            | Output
            | Loop { getLoop :: [BFInst] }
            deriving Show

data BFZipper a = BFZipper { getLeft :: [a]
                           , getCurr :: a
                           , getRight :: [a] }

forward :: BFZipper a -> BFZipper a
forward (BFZipper l a (x:xs)) = BFZipper (a:l) x xs

backward :: BFZipper a -> BFZipper a
backward (BFZipper (x:xs) a r) = BFZipper xs x (a:r)

modifyValue :: (a -> a) -> BFZipper a -> BFZipper a
modifyValue f (BFZipper ls x rs) = BFZipper ls (f x) rs


initState = BFZipper zeroes 0 zeroes
  where zeroes = repeat 0

type Cell = Word8
type BFState = StateT (BFZipper Cell) IO


eval :: BFInst -> BFState ()
eval Next = modify forward
eval Prev = modify backward
eval Inc  = modify $ modifyValue (+1)
eval Dec  = modify $ modifyValue (subtract 1)
eval Input  = liftIO getChar >>= modify . modifyValue . const . toEnum . ord
eval Output = gets getCurr >>= liftIO . putChar . chr . fromEnum
eval (Loop xs) = gets getCurr >>= foo
  where foo 0 = return ()
        foo _ = mapM_ eval (xs ++ [Loop xs])


runBF :: [BFInst] -> IO ()
runBF xs = evalStateT (mapM_ eval xs) initState


parseBF :: String -> Either ParseError [BFInst]
parseBF = parse bfParser "syntax error"

parseRunBF :: String -> IO ()
parseRunBF input = case parseBF input of
  Right insts -> runBF insts
  Left _  -> return ()

bfParser :: Parser [BFInst]
bfParser = many instParser

instParser :: Parser BFInst
instParser = (char '+' >> return Inc) <|>
             (char '-' >> return Dec) <|>
             (char '<' >> return Prev) <|>
             (char '>' >> return Next) <|>
             (char '.' >> return Output) <|>
             (char ',' >> return Input) <|>
             loopParser

loopParser :: Parser BFInst
loopParser = do
  char '['
  insts <- many instParser
  char ']'
  return $ Loop insts