bf.hs

import qualified Control.Monad.State as S
import Control.Applicative ((<$>), (<*>))
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import Control.Monad (unless)

data BF = Token Char | Loop [BF] deriving Show

type Tape = M.Map Int Char
type Env = (Int, Tape)

pop :: S.State String (Maybe Char)
pop = do
  tmp <- S.get
  case tmp of
       [] -> return Nothing
       (x:xs) -> do
         S.put xs
         return $ Just x

parse :: String -> [BF]
parse = S.evalState parse'

parse' :: S.State String [BF]
parse' = do
  c <- fromMaybe ']' `fmap` pop
  case c of
       '[' -> (:) <$> (Loop `fmap` parse') <*> parse'
       ']' -> return []
       _ -> (Token c :) `fmap` parse'

exec :: [BF] -> IO ()
exec bfs = S.evalStateT (mapM_ exec' bfs) (0, M.empty)

exec' :: BF -> S.StateT Env IO ()
exec' (Token '>') = do
  (i, m) <- S.get
  S.put (succ i, m)
exec' (Token '<') = do
  (i, m) <- S.get
  S.put (pred i, m)
exec' (Token '+') = do
  (i, m) <- S.get
  let m' = M.insert i (succ $ M.findWithDefault '\NUL' i m) m
  S.put (i, m')
exec' (Token '-') = do
  (i, m) <- S.get
  let m' = M.insert i (pred $ M.findWithDefault '\NUL' i m) m
  S.put (i, m')
exec' (Token '.') = do
  (i, m) <- S.get
  S.liftIO $ putChar $ M.findWithDefault '\NUL' i m
exec' it@(Loop bfs) = do
  (i, m) <- S.get
  unless (M.findWithDefault '\NUL' i m == '\NUL') $ do
    mapM_ exec' bfs
    exec' it
exec' _ = return ()

main :: IO ()
main =
  exec $ parse "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."