Brainf**k Interpreter

bf.hs

{-# LANGUAGE BangPatterns #-}
import Control.Applicative
import System.Environment

data Tape = T { current :: !Int, lefts, rights :: [Int] }

inc, dec, left, right :: Tape -> Tape
inc (T c ls rs) = T (c+1) ls rs
dec (T c ls rs) = T (c-1) ls rs
left (T c (l:ls) rs) = T l ls (c:rs)
right (T c ls (r:rs)) = T r (c:ls) rs
set :: Int -> Tape -> Tape
set c (T _ ls rs) = T c ls rs

get :: IO Int; put :: Int -> IO ()
get = fromEnum <$> getChar
put = putChar . toEnum

run :: String -> IO Tape
run str = run' str $ T 0 cells cells
  where
    run' cs = go cs return
    go [] k = k
    go (c:cs) k = case c of
                    '>' -> go cs (fmap right . k)
                    '<' -> go cs (fmap left  . k)
                    '+' -> go cs (fmap inc   . k)
                    '-' -> go cs (fmap dec   . k)
                    '.' -> go cs ((liftA2 (>>) (put . current) return =<<) . k)
                    ',' -> go cs (((<$> get) . flip set =<<) . k)
                    '[' -> let (loop,rest) = find_loop cs
                           in go rest ((untilM ((==0) . current) (run' loop) =<<) . k)
                    _   -> go cs k
    cells = repeat 0

runBrainfuck :: String -> IO ()
runBrainfuck bf = do run bf; return ()

-- helloworld =  "+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-."
--            ++ "------------.<++++++++.--------.+++.------.--------.>+."

untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
untilM p k a | p a = return a
             | otherwise = k a >>= untilM p k

find_loop cs =
    let f 0 (']':r) = ("", r)
        f n (']':r) = let ~(l,r') = f (n-1) r in (']':l,r')
        f n ('[':r) = let ~(l,r') = f (n+1) r in ('[':l,r')
        f n (c:cs)  = let ~(l,r') = f n cs    in (c:l,  r')
    in f 0 cs

main = fmap head getArgs >>= readFile >>= runBrainfuck

Makefile

bf: bf.hs
	ghc --make -O2 bf