BrainfuckWithoutInfiniteList.hs

import Data.Char
import Data.Word
import Data.List
import Data.Function
import Data.Array.Unboxed
import Data.Array.IO
import Control.Applicative
import Text.Parsec hiding ((<|>), many)
import Text.Parsec.String
import System.IO
import System.Environment

type Insn  = Int
type Insns = UArray Int Insn
type Tape  = IOUArray Int Word8

maxInsn :: Insn
maxInsn = 16

parser :: Parser [Insn]
parser = foldl1' (.) <$> many parser' <*> pure [0]
    where
      parser' = ((1:) <$ char '>')
            <|> ((2:) <$ char '<')
            <|> ((3:) <$ char '+')
            <|> ((4:) <$ char '-')
            <|> ((5:) <$ char ',')
            <|> ((6:) <$ char '.')
            <|> (id   <$ noneOf "[]")
            <|> ((\body c -> (length body)+maxInsn:body ++ c) <$> between (char '[') (char ']') parser)

eval :: [Insn] -> IO ()
eval insn_list = do
  let insns = listArray (0, (length insn_list)-1) insn_list :: Insns
  tape <- newArray (0, 29999) 0 :: IO Tape
  eval' insns 0 tape 0 0 []
    where
      eval' :: Insns -> Int -> Tape -> Int -> Word8 -> [Int] -> IO ()
      eval' insns pc tape ptr v stk =
          case insns!pc of
            0 -> case stk of
                   []     -> return ()
                   (x:xs) -> eval' insns x tape ptr v xs
            1 -> do v' <- readArray tape p'
                    eval' insns pc' tape p' v' stk   where p' = ptr+1
            2 -> do v' <- readArray tape p'
                    eval' insns pc' tape p' v' stk   where p' = ptr-1
            3 -> do writeArray tape ptr v'
                    eval' insns pc' tape ptr v' stk  where v' = v+1
            4 -> do writeArray tape ptr v'
                    eval' insns pc' tape ptr v' stk  where v' = v-1
            5 -> do c <- getChar
                    let v' = toEnum $ ord c
                    writeArray tape ptr v'
                    eval' insns pc' tape ptr v' stk
            6 -> do putChar $ chr (fromEnum v)
                    eval' insns pc' tape ptr v stk
            n -> if v == 0
                    then eval' insns (pc' + (n-maxInsn)) tape ptr v stk
                    else eval' insns pc' tape ptr v (pc:stk)
          where pc' = pc+1

main = do
  hSetBuffering stdin  NoBuffering
  hSetBuffering stdout NoBuffering
  (file:_) <- getArgs
  result   <- parseFromFile parser file
  case result of
    Left  err   -> print err
    Right insns -> eval insns