brainfunc

import qualified Control.Exception as E
import Control.Monad
import Data.Array.IO
import Data.Char
import Data.IORef
import qualified Data.Map as M
import Data.Word
import System.Environment

data Exp = Back | Forward | Minus | Plus | In | Out | Loop [Exp]
data State = State (IORef Int) (IOArray Int Word8)

modifyArray :: (Ix i) => IOArray i e -> i -> (e -> e) -> IO ()
modifyArray array index f = do
  old <- readArray array index
  writeArray array index (f old)

eval :: Exp -> State -> IO ()

eval Back (State ptr _) = modifyIORef ptr (subtract 1)
eval Forward (State ptr _) = modifyIORef ptr (+1)

eval Minus (State ptr tape) = do
  curptr <- readIORef ptr
  modifyArray tape curptr (subtract 1)

eval Plus (State ptr tape) = do
  curptr <- readIORef ptr
  modifyArray tape curptr (+1)

eval In (State ptr tape) = do
  curptr <- readIORef ptr
  char <- getChar `E.catch` ((\_ -> return '\xFF') :: E.IOException -> IO Char)
  writeArray tape curptr $ fromIntegral $ ord char

eval Out (State ptr tape) = do
  curptr <- readIORef ptr
  char <- readArray tape curptr
  putChar $ chr $ fromIntegral char

eval exp@(Loop body) st@(State ptr tape) = do
  curptr <- readIORef ptr
  val <- readArray tape curptr
  when (val /= 0) $ do
    sequence $ map (flip eval st) body
    eval exp st

simpleOps = M.fromList [
  ('<', Back),
  ('>', Forward),
  ('-', Minus),
  ('+', Plus),
  (',', In),
  ('.', Out)]

parse :: String -> ([Exp], String)

parse "" = ([], "")
parse (x:xs) = case M.lookup x simpleOps of
    Just exp -> let (restExp, restCode) = parse xs in (exp:restExp, restCode)
    Nothing -> case x of
      '[' ->
        let
          (body, next) = parse xs
          (restExp, restCode) = parse next
        in ((Loop body):restExp, restCode)
      ']' -> ([], xs)
      _ -> parse xs

main :: IO ()

main = do
  [pfile] <- getArgs
  code <- readFile pfile
  let (exps, _) = parse code
  ptr <- newIORef 0
  tape <- newArray (0, 4096) 0
  sequence_ $ map (flip eval (State ptr tape)) exps