B.hs

{-# LANGUAGE OverloadedStrings #-}
import Data.Array.IO
import Data.Array.Base
import Control.Applicative
import Control.Monad
import Data.Attoparsec.Char8
import qualified Data.ByteString.Char8 as B
import System.Environment

data Primitive =
    MoveLeft  {-# UNPACK #-} !Int
  | MoveRight {-# UNPACK #-} !Int
  | Incr      {-# UNPACK #-} !Int
  | Decr      {-# UNPACK #-} !Int
  | Output
  | Input
  | Loop [Primitive]

primitive :: Parser Primitive
primitive =
      MoveLeft  . B.length <$> takeWhile1 (== '<')
  <|> MoveRight . B.length <$> takeWhile1 (== '>')
  <|> Incr      . B.length <$> takeWhile1 (== '+')
  <|> Decr      . B.length <$> takeWhile1 (== '-')
  <|> char8 '.' *> return Output
  <|> char8 ',' *> return Input

instruction :: Parser Primitive
instruction = primitive <|> loop

loop :: Parser Primitive
loop = char8 '[' *> (Loop <$> bf) <* char8 ']'

bf :: Parser [Primitive]
bf = many instruction

type Tape = IOUArray Int Int
type Ptr = Int

eval :: [Primitive] -> IO ()
eval ps = do
  tape <- newArray (1,30000) 0 :: IO Tape
  void $ go ps tape 1
 where
  go :: [Primitive] -> Tape -> Ptr -> IO Ptr

  go [] _ sp = return sp

  go (MoveLeft  n:ps) tape sp = go ps tape (sp - n)
  go (MoveRight n:ps) tape sp = go ps tape (sp + n)

  go (Incr n:ps) tape sp = do
    v <- unsafeRead tape sp
    unsafeWrite tape sp (v + n)
    go ps tape sp

  go (Decr n:ps) tape sp = do
    v <- unsafeRead tape sp
    unsafeWrite tape sp (v - n)
    go ps tape sp

  go (Output:ps) tape sp = do
    putChar . toEnum =<< unsafeRead tape sp
    go ps tape sp

  go (Input:ps) tape sp = do
    getChar >>= unsafeWrite tape sp . fromEnum
    go ps tape sp

  go (Loop p:ps) tape sp0 = lgo sp0 >>= go ps tape
   where
    lgo sp = do
      v <- unsafeRead tape sp
      if v /= 0
        then go p tape sp >>= lgo
        else return sp

main :: IO ()
main = do
  program <- B.readFile =<< head <$> getArgs
  let sanitized = B.filter (`B.elem` "<>+-.,[]") program
  either error eval (parseOnly bf sanitized)