Brainf*ck in Haskell

_brainfuck.hs

import Data.Char (chr)
    
brainfuck :: String -> IO String
brainfuck cmds = loop ([], (return 0), (repeat $ return 0)) 0 []
    where
      max = length cmds
      loop :: ([IO Int], IO Int, [IO Int]) -> Int -> [IO Char] -> IO String 
      loop (xs,y,zs) index outs
           | index == max = sequence (reverse outs)
           | otherwise    = cnd (cmds !! index)
          where
            cnd '>' = loop ((y:xs), (head zs), tail zs) (index+1) outs
            cnd '<' = loop (tail xs, (head xs), (y:zs)) (index+1) outs
            cnd '+' = loop (xs, (+ 1) <$> y, zs) (index+1) outs
            cnd '-' = loop (xs, (+ (-1)) <$> y, zs) (index+1) outs
            cnd '.' = loop (xs, y, zs) (index+1) ((chr <$> y):outs)
            cnd ',' = loop (xs, read <$> getLine, zs) (index+1) outs
            cnd '[' = let diff = serch '[' ']' (drop (index+1) cmds) in
                      do y' <- y 
                         if y' == 0 then
                             loop (xs, y, zs) (index+diff+1) outs 
                         else
                             loop (xs, y, zs) (index+1) outs
            cnd ']' = let diff = serch ']' '[' (reverse $ take index cmds) in
                      do y' <- y
                         loop (xs, y, zs) (index-diff) outs
            cnd  _  = loop (xs, y, zs) (index+1) outs

serch :: Char -> Char -> [Char] -> Int
serch a b cmds = loop 1 0 cmds
    where
      loop 0 i _ = i
      loop n i (l:ls)
           | l == a = loop (n+1) (i+1) ls
           | l == b = loop (n-1) (i+1) ls
           | otherwise = loop n (i+1) ls

main = getContents >>= brainfuck . concat . lines >>= putStrLn

brainfuck.hs

module Main where

import Data.Char (chr, ord)
import System.Environment (getArgs)

main :: IO ()
main = do
  [filepath] <- getArgs
  prog <- readFile filepath
  _ <- run $ initMachine prog
  putStrLn ""

data Machine =
  Machine { programOf :: Program, memOf :: Tape Int } deriving (Show)

data Tape a = Tape { front :: [a], current :: a, back :: [a] } deriving (Show)
type Program = Tape (Maybe Char)

mapCrr :: (a -> a) -> Tape a -> Tape a
mapCrr f tape = tape { current = f (current tape) }

moveFront :: Tape a -> Tape a
moveFront (Tape [] _ _) = error "front is empty."
moveFront (Tape f c b) = Tape (tail f) (head f) (c : b)

moveBack :: a -> Tape a -> Tape a
moveBack a (Tape f c []) = Tape (c : f) a []
moveBack _ (Tape f c b) = Tape (c : f) (head b) (tail b)

initMachine :: String -> Machine
initMachine = initMachine' . flip mappend [fin] . fmap Just
  where
    initMachine' s = Machine (Tape [] (head s) (tail s)) (Tape [] 0 [])

fin :: Maybe Char
fin = Nothing

run :: Machine -> IO Machine
run = loopM run' ((/=) fin . current . programOf)

loopM :: Monad m => (a -> m a) -> (a -> Bool) -> a -> m a
loopM f p a = if p a then f a >>= loopM f p else return a

run' :: Machine -> IO Machine
run' m@(Machine prog mem) =
  (\m' -> m' { programOf = moveBack' $ programOf m' }) <$> cond (current prog)
  where
    cond (Just '>') = return $ Machine prog (moveBack 0 mem)
    cond (Just '<') = return $ Machine prog (moveFront mem)
    cond (Just '+') = return $ Machine prog (mapCrr (+ 1) mem)
    cond (Just '-') = return $ Machine prog (mapCrr (+ (-1)) mem)
    cond (Just '.') = return m <* putChar (chr $ current mem)
    cond (Just ',') =
      (\c -> Machine prog (mapCrr (const $ ord c) mem)) <$> getChar
    cond (Just '[') = return . flip Machine mem $
      (if current mem == 0 then jump ('[', ']') moveBack' else id) prog
    cond (Just ']') = return . flip Machine mem $
      (if current mem /= 0 then jump (']', '[') moveFront else id) prog
    cond _   = return m
    moveBack' = moveBack fin

jump :: (Char, Char) -> (Program -> Program) -> Program -> Program
jump (a, b) f = go 1
  where
    go 0 prog = prog
    go n prog = go (updateCounter (p a) (p b) (current $ f prog) n) (f prog)
    p x = (==) (Just x)

updateCounter :: (a -> Bool) -> (a -> Bool) -> a -> Int -> Int
updateCounter p q a = (+) (if p a then 1 else if q a then -1 else 0)

hw.bf

+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.
------------.<++++++++.--------.+++.------.--------.>+.