Haskell 3-stage Brainfuck parser/reducer/evaluator

eval.hs

module Eval (bf_eval) where
import qualified Data.Vector.Mutable as MV
import Control.Monad.ST (runST)
import Data.Char (chr)
import Reducer

bf_eval :: [ISC] -> String
bf_eval instrs =
  runST $ bf_eval' instrs
	where
	bf_eval' instrs = do
		cells <- MV.replicate 3000 (0 :: Int)
		eval cells instrs 0 ""

		where
		eval cells [] _ out = return $ reverse out
		eval cells (x:xs) ptr out =
			case x of
				Modify i -> do
					p <- MV.read cells ptr
					MV.write cells ptr (p + i)
					eval cells xs ptr out
				Move i -> eval cells xs (ptr + i) out
				OutI -> do
					c <- MV.read cells ptr
					eval cells xs ptr (chr c:out)
				LoopI body ->
					let loop ptr' out' = do
						p <- MV.read cells ptr
						if p == 0 then
							return out'
						else do
							out'' <- eval cells body ptr' out'
							loop ptr' out''
					in do
						out' <- loop ptr out
						eval cells xs ptr out'

ir.hs

module IR (Instruction(..), bf_to_ir) where

-- Simple IR for Brainfuck programs
data Instruction = LeftI
  			 | RightI
				 | Plus
				 | Minus
				 | Out
				 | Loop [Instruction]
				 deriving (Show, Eq)

bf_to_ir :: String -> [Instruction]

bf_to_ir [] = []
bf_to_ir ('[':r) =
	let x = bf_to_ir r
	    y = take (length x - 1) x in
	case last x of
	  Loop r' -> Loop y : r'
	  _ -> error "unclosed loop?"
bf_to_ir (']':r) =
	[Loop (bf_to_ir r)]
bf_to_ir ('+':r) = Plus : bf_to_ir r
bf_to_ir ('-':r) = Minus : bf_to_ir r
bf_to_ir ('<':r) = LeftI : bf_to_ir r
bf_to_ir ('>':r) = RightI : bf_to_ir r
bf_to_ir ('.':r) = Out : bf_to_ir r

main.hs

module Main (main) where
import Control.Exception (assert)
import IR
import Reducer
import Eval

main =
  let program = "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>."
	    ir = bf_to_ir program
	    reduced = bf_reduce ir []
	in
	putStrLn program >>
	putStrLn "" >>
	print ir >>
	putStrLn "" >>
	print reduced >>
	putStrLn "" >>
	print (bf_eval reduced)

reducer.hs

module Reducer (ISC(..), bf_reduce) where
import IR

-- Reduce Brainfuck instructions (from the IR) into more compact instructions
data ISC = Modify Int -- *ptr += x
         | Move Int -- ptr += x
         | OutI
         | LoopI [ISC]
         deriving (Show, Eq)

-- Count and reduce instructions
reduceInstruction :: [Instruction] -> (Instruction, Instruction) -> Int -> (Int, [Instruction])
reduceInstruction [] _ n = (n, [])
reduceInstruction r@(x:xs) ins@(ins_inc, ins_dec) n
  | x == ins_inc = reduceInstruction xs ins (n+1)
  | x == ins_dec = reduceInstruction xs ins (n-1)
  | otherwise = (n, r)

bf_reduce ::  [Instruction] -> [ISC] -> [ISC]

-- base case
bf_reduce [] prg = reverse prg

-- beginning
bf_reduce (x:xs) [] =
  case x of
		Plus -> bf_reduce xs [Modify 1]
		Minus -> bf_reduce xs [Modify (-1)]
		LeftI -> bf_reduce xs [Move (-1)]
		RightI -> bf_reduce xs [Move 1]
		Out -> bf_reduce xs [OutI]
		Loop body -> bf_reduce xs [LoopI (bf_reduce body [])]

bf_reduce ins@(x:xs) prg@(p:ps) =
	case x of
		Plus -> reduceModify p $ reduceInstruction ins (Plus, Minus) 0
		Minus -> reduceModify p $ reduceInstruction ins (Plus, Minus) 0
		LeftI -> reduceMove p $ reduceInstruction ins (RightI, LeftI) 0
		RightI -> reduceMove p $ reduceInstruction ins (RightI, LeftI) 0
		Out -> bf_reduce xs (OutI:prg)
		Loop body -> bf_reduce xs (LoopI (bf_reduce body []) : prg)

	where
		reduceModify (Modify i) (n,r) = bf_reduce r (Modify (i+n) : ps) -- mutate existing Modify
		reduceModify _ (n,r) = bf_reduce r (Modify n : prg) -- add new Modify

		reduceMove (Move i) (n,r) = bf_reduce r (Move (i+n) : ps)
		reduceMove _ (n,r) = bf_reduce r (Move n : prg)