Brainfuck Interpreter

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
import Prelude hiding (catch)
import Control.Exception (catch)
import System.IO (stdin, hFlush, hGetContents, openFile, IOMode(ReadMode))
import System.IO.Error (isEOFError)
import System.Environment (getArgs)
import Data.Sequence (singleton, Seq, (<|), (|>), index, length, adjust, update)
import Control.Monad (void, liftM, ap)
import Control.Arrow ((***))

type Program = [Instruction]

data Instruction = MovL | MovR 
                 | Dec  | Inc
                 | Inp  | Out
                 | Loop Program

main :: IO ()
main = do
  args <- getArgs
  prog <- if Prelude.length args > 0
             then hGetContents =<< openFile (head args) ReadMode
             else getLine
  exec_ . parse $ prog

parse :: String -> Program
parse []       = []
parse ('[':xs) = let (il, ol) = closing ('[', ']') xs in
                (Loop . parse$il)
                      : parse ol
parse ('<':xs) = MovL : parse xs
parse ('>':xs) = MovR : parse xs
parse ('-':xs) = Dec  : parse xs
parse ('+':xs) = Inc  : parse xs
parse (',':xs) = Inp  : parse xs
parse ('.':xs) = Out  : parse xs
parse ( _ :xs) =        parse xs

closing :: (Char, Char) -> String -> (String, String)
closing brc = (reverse *** reverse) . fst . foldl (folder brc) (("", ""), 1)
  where folder :: (Char, Char) -> ((String, String), Int) -> Char -> ((String, String), Int)
        folder (co, cc) ((is, os), ct) c
          | ct >  0 && c == co = ((c:is,   os), ct + 1)
          | ct >  0 && c == cc = ((c:is,   os), ct - 1)
          | ct >  0            = ((c:is,   os), ct    )
          | ct == 0            = ((  is, c:os),      0)

exec_ :: Program -> IO ()
exec_ prog = void $ exec prog (singleton 0, 0)
  
exec :: Program -> (Seq Integer, Int) -> IO (Seq Integer, Int)
exec [] mm = return mm
exec (MovL:ps) (mem, pnt) = exec ps
  $ if pnt == 0
       then (0 <| mem, pnt    )
       else (     mem, pnt - 1)
exec (MovR:ps) (mem, pnt) = exec ps
  $ flip (,) (pnt + 1)
  $ if Data.Sequence.length mem <= pnt + 1
       then mem |> 0
       else mem
exec (Dec :ps) (mem, pnt) = exec ps (adjust (+ (-1)) pnt mem, pnt)
exec (Inc :ps) (mem, pnt) = exec ps (adjust (+   1 ) pnt mem, pnt)
exec (Inp :ps) (mem, pnt) = do
  c <- (liftM (toEnum . fromEnum) getChar) `catch` excHndl
  exec ps (update pnt c mem, pnt)
  where excHndl :: IOError -> IO Integer
        excHndl e
          | isEOFError e = return $ -1
          | otherwise    = ioError e
exec (Out :ps) mm@(mem, pnt) = do
  putChar . toEnum . fromEnum . index mem $ pnt
  exec ps mm
exec pro@(Loop q:ps) mm@(mem, pnt) = do
  nm <- exec q mm
  flip exec nm
    $ if mem `index` pnt == 0
         then ps
         else pro
64:8: Warning: Redundant bracket
Found:
(liftM (toEnum . fromEnum) getChar) `catch` excHndl
Why not:
liftM (toEnum . fromEnum) getChar `catch` excHndl