K.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

import Control.Applicative
import Control.Monad.Loops
import Control.Monad.State.Strict
import Data.Either
import Data.Attoparsec.Char8
import qualified Data.ByteString.Char8 as B
import Data.List.Zipper
import System.Environment

newtype BF a = BF { unBF :: StateT (Zipper Int) IO a }
  deriving (Functor, Monad, MonadIO, MonadState (Zipper Int))

runBF :: BF a -> IO a
runBF = flip evalStateT tape . unBF
  where tape = fromList $ replicate 30000 0

bf :: Parser (BF ())
bf = (sequence_ <$>) . many $
      (takeWhile1 (== '>') >>= next . B.length)
  <|> (takeWhile1 (== '<') >>= prev . B.length)
  <|> (takeWhile1 (== '+') >>= incr . B.length)
  <|> (takeWhile1 (== '-') >>= decr . B.length)
  <|> "." .*> return (liftIO . putChar . toEnum =<< gets cursor)
  <|> "," .*> return (liftIO getChar >>= modify . replace . fromEnum)
  <|> whileM_ ((/= 0) <$> gets cursor) <$> ("[" .*> bf <*. "]")
  <|> notChar ']' *> bf

next, prev, incr, decr :: Int -> Parser (BF ())
next !n = return $ modify (apply n right)
prev !n = return $ modify (apply n left)
incr !n = return $ modify $ \z -> replace (cursor z + n) z
decr !n = return $ modify $ \z -> replace (cursor z - n) z

apply :: Int -> (a -> a) -> (a -> a)
apply !n !f = go n f f
 where
  go !1 !f  _ = f
  go !n !f !g = go (n-1) (f.g) g
  {-# INLINE go #-}

main = do
  program <- B.readFile =<< head <$> getArgs
  either error runBF (parseOnly bf program)