User:Jan jelo/a BF interpreter in Haskell

This is a Brainfuck interpreter in Haskell written by User:Jan jelo.

import Data.Char (chr,ord)
main = run (filter(\x->any(==x)"+-<>.,[]")pgrm) 0 (Tape(Stack[])(Stack[])) 0 0
pgrm="++++++++++[>+++++++>++++++++++>+++<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+."
--Hello World!
data Stack = Stack [Int] deriving (Show)
pop (Stack []) = Stack []
pop (Stack (x:xs)) = Stack xs
top (Stack []) = 0
top (Stack (x:xs)) = x
psh (Stack x) a = Stack (a:x)
inc 255 = 0
inc x = x+1
dec 0 = 255
dec x = x-1

data Tape = Tape Stack Stack 
instance Show Tape where
 show (Tape(Stack x)(Stack y)) = "Tape" ++ show(reverse x) ++ show y
movl (Tape x y) = Tape(pop x)(psh y (top x))
movr (Tape x y) = Tape(psh x (top y))(pop y)
cur (Tape x y) = top x
curSet (Tape x y) a = (Tape (psh(pop x)a)y)
curInc x = curSet x (inc $ cur x)
curDec x = curSet x (dec $ cur x)

lstref (x:xs) 0 = x
lstref (x:xs) i = lstref xs (i-1)
lstref "" _ = chr 0

run pgrm pc tape state i =
 let cmd = lstref pgrm pc in
      case state of
        0 -> case cmd of 
          '+' -> run pgrm pc (curInc tape) 1 i
          '-' -> run pgrm pc (curDec tape) 1 i
          '<' -> run pgrm pc (movl tape) 1 i
          '>' -> run pgrm pc (movr tape) 1 i
          '[' -> run pgrm pc tape (if cur tape==0 then 2 else 1) 0
          ']' -> run pgrm pc tape (if cur tape>0 then 3 else 1) 0
          ',' -> do
            x <- getChar
            run pgrm pc (curSet tape (ord x)) 1 i
          '.' -> do
            putStr [chr$cur tape]
            run pgrm pc tape 1 i
          _ -> run pgrm pc tape 4 i
        1 -> run pgrm (pc+1) tape 0 i
        2 -> case cmd of 
          '[' -> (if i-1==0 then
                  run pgrm pc tape 0 0
                 else
                  run pgrm (pc+1) tape 2 (i-1))
          ']' -> (if i+1==0 then
                  run pgrm pc tape 0 0
                 else
                  run pgrm (pc+1) tape 2 (i+1))
          _   -> run pgrm (pc+1) tape 2 i 
        3 -> case cmd of 
          '[' -> if i-1==0 then
                  run pgrm pc tape 0 0
                 else
                  run pgrm (pc-1) tape 3 (i-1)
          ']' -> if i+1==0 then
                  run pgrm pc tape 0 0
                 else
                  run pgrm (pc-1) tape 3 (i+1)
          _   -> run pgrm (pc-1) tape 3 i
        _ -> pure ()