-- A Simple Brainfuck Interpreter

import System.Environment

-- Parser

data Command = Inc | Dec | Next | Prev | Put | Get | While [Command]
               deriving (Show, Eq)
type Program = [Command]

parse :: String -> Program
parse s = program where (program, "") = parse1 s

parse1 :: String -> (Program, String)

parse1 "" = ([], "")
parse1 (']':xs) = ([], xs)

parse1 ('[':xs) = (While cmds1 : cmds2, rest2)
    where (cmds1, rest1) = parse1 xs
          (cmds2, rest2) = parse1 rest1

parse1 (x:xs) = (parse2 x, rest)
    where (cmds, rest) = parse1 xs
          parse2 :: Char -> Program
          parse2 '>' = Next : cmds
          parse2 '<' = Prev : cmds
          parse2 '+' = Inc : cmds
          parse2 '-' = Dec : cmds
          parse2 '.' = Put : cmds
          parse2 ',' = Get : cmds
          parse2 _ = cmds

-- Tape

type Tape = ([Char], Int)
tape0 = (['\NUL', '\NUL'..], 0) :: Tape

getCell :: Tape -> Char -- Get value of current position
getCell (cs, i) = cs !! i

setCell :: Tape -> Char -> Tape
setCell (cs, i) c = (take i cs ++ (c : drop (i + 1) cs), i)

inc, dec, next, prev :: Tape -> Tape
inc t = setCell t (succ $ getCell t)
dec t = setCell t (pred $ getCell t)
next (cs, i) = (cs, i + 1)
prev (cs, i) = (cs, i - 1)

-- Evaluator

type Status = (Program, Tape, [Char], [Char])

step :: (Tape -> Tape) -> Status -> Status
step f (c:cs, tape, inp, outp) = eval (cs, f tape, inp, outp)

eval :: Status -> Status
                                                
eval (Get : cmds, tape, (i:inp), outp) = eval (cmds, setCell tape i, inp, outp)
eval (Get : _, _, "", _) = error "EOF"

eval s @ (Put : _, tape, _, _) = (cmds, tape1, inp, getCell tape : outp)
    where (cmds, tape1, inp, outp) = step id s

eval s @ (Inc : _, _, _, _) = step inc s
eval s @ (Dec : _, _, _, _) = step dec s
eval s @ (Next : _, _, _, _) = step next s
eval s @ (Prev : _, _, _, _) = step prev s

eval s @ (While cmds : cmds1, tape, inp, outp) = while (getCell tape)
       where while '\NUL' = step id s
             while _      = (cmds2, tape2, inp2, outp1 ++ outp2)
                 where (_ , tape1, inp1, outp1)
                           = eval (cmds, tape, inp, outp)
                       (cmds2, tape2, inp2, outp2)
                           = eval (While cmds : cmds1, tape1, inp1, outp1)

eval ([], t, i, _) = ([], t, i, "")

-- Environment

run :: Program -> [Char] -> [Char]
run cmds inp = outp where (_,_,_, outp) = eval (cmds, tape0, inp, "")

main :: IO ()
main = do cs <- getContents
          args <- getArgs
          source <- readFile (head args)
          putStr $ run (parse source) cs

-- Tests

tape :: Program -> [Char] -> [Char]
tape cmds inp = t where (_,(t,_),_,_) = eval (cmds, tape0, inp, "")

tests  = map test [1..13]
test 1 = parse ">" == [Next]
test 2 = parse "[>]" == [While [Next]]
test 3 = parse "[>[><]]" == [While [Next, While [Next, Prev]]]
test 4 = parse "hello" == []
test 5 = inc ("hello", 1) == ("hfllo", 1)
test 6 = dec ("hello", 1) == ("hdllo", 1)
test 5 = True
test 6 = True
test 7 = run [Get,Put,Get,Put,Get,Put] "Sun" == "Sun"
test 8 = take 5 (run [Get, While[Get, Put]] "Hello World") == "ello "
test 9 = (fromEnum $ run [Inc, Inc, Dec, Put] "" !! 0) == 1
test 10 = take 3 (tape [Get,Next,Get,Next,Get,Next] "Mon") == "Mon"
test 11 = run (parse ",.,.,.,.,.") "hello" == "hello"
test 12 = run (parse "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++.") "" == "A"
test 13 = run (parse "++++++++++ [>+++++++>++++++++++>+++>+<<<<-] >++. >+. +++++++. . +++. >++. <<+++++++++++++++. >. +++. ------. --------. >+. >. ") "" == "Hello World!\n"