brainfuck interpreter

gistfile1.hs

import Control.Monad
import Control.Monad.State
import Data.Array.Unboxed
import Data.Word
import Data.Char
import qualified Data.Map as M
import Data.Ix

data Bf = Bf { getArray      :: UArray Int Word8
             , getPointer    :: Int
             }
    deriving (Show)

type IntState = StateT Bf IO ()

newBf :: Bf
newBf = Bf (array (1,30000) []) 1

-- >
incPointer :: IntState
incPointer = do
  modify (\(Bf arr p) -> Bf arr (p+1))
  return ()

-- <
decPointer :: IntState
decPointer = do
  modify (\(Bf arr p) -> Bf arr (p-1))
  return ()

setData :: Word8 -> IntState
setData val = do
  modify (\(Bf arr p) -> Bf (arr//[(p, val)]) p)
  return ()

-- +
incData :: IntState
incData = do
  modify (\(Bf arr p) -> Bf (arr//[(p,(arr!p)+1)]) p)
  return ()

-- -
decData :: IntState
decData = do
  (Bf arr p) <- get
  put $ Bf (arr//[(p,(arr!p)-1)]) p

-- .
printPointer :: IntState
printPointer = do
  (Bf arr p) <- get
  liftIO $ putStr $ [chr (fromIntegral (arr!p) :: Int)]
  return ()

-- ,
readByte :: IntState
readByte = do
  a <- liftIO getChar
  setData (read (show (ord a)) :: Word8)

-- [
moveForward :: IntState
moveForward = do
  bf@(Bf arr p) <- get
  if (fromIntegral (arr!p) == 0)
    then moveClosingBracket
    else do put (Bf arr (p+1))
            return ()

-- ]
moveBackward :: IntState
moveBackward = do
  bf@(Bf arr p) <- get
  if (fromIntegral (arr!p) /= 0)
    then moveOpeningBracket
    else do put $ Bf arr (p+1)
            return ()

moveOpeningBracket :: IntState
moveOpeningBracket = do
  (Bf arr p) <- get
  if (fromIntegral (arr!p) == (ord '['))
    then do put $ Bf arr (p+1)
            return ()
    else do put $ Bf arr (p-1)
            moveOpeningBracket

moveClosingBracket :: IntState
moveClosingBracket = do
  (Bf arr p) <- get
  if (fromIntegral (arr!p) == (ord ']'))
    then do put $ Bf arr (p+1)
            return ()
    else do put $ Bf arr (p+1)
            moveClosingBracket

ops :: M.Map Char IntState
ops = M.fromList [ ('>', incPointer)
                 , ('<', decPointer)
                 , ('+', incData)
                 , ('-', decData)
                 , ('[', moveForward)
                 , (']', moveBackward)
                 , ('.', printPointer)
                 , (',', readByte)
                 ]

run :: IntState
run = do
  c <- liftIO getChar
  case M.lookup c ops of
    Nothing -> do liftIO $ putStrLn $ "err " ++ [c]
                  return ()
    Just op -> do op
                  --ns <- get
                  --liftIO $ putStrLn $ show ns
                  run

main :: IO ()
main = do
  evalStateT run newBf