Eval.hs

{-|
Module      : Language.Brainfuck.Eval
Description : Evaluator for the BF language
Copyright   : (c) Allele Dev, 2014
License     : BSD-3
Maintainer  : allele.dev@gmail.com
Stability   : experimental
Portability : POSIX
-}
module Language.Brainfuck.Eval (
  eval
) where

import Data.Array ((//), (!))
import Data.Char (ord, chr)
import Data.Tuple (swap)
import Data.Word (Word8)

import Language.Brainfuck.Types
import Language.Brainfuck.Parse

{-|

`eval` operates over the given tape, parses the string, and returns the state of the tape.

Potential unhandled errors:

* Out of bounds access to the tape
* Infinite loops
* Exceptions thrown by `print`
* Exceptions thrown by `putChar`

Handled errors:

* Matching jump not found for '[' and ']': terminate eval and return tape

As a result of evaluating the BF program, the following instructions
are effectful:

* ',': pauses evaluation to receive user input
* '.': prints the tape contents at DP as a Char

Here's how `eval` might be called:

>>> let tape = listArray (0,99) (replicate 100 0)
>>> eval tape "+.+."
\1\2
>>> eval tape ",."
aa
-}
eval :: Tape -> String -> IO Tape
eval storage program =
  let instructions = parse program
      jumpPairs = matchJumps instructions

  in case jumpPairs of
     (Right e) -> print e >> return storage
     (Left j)  -> let jrev = map swap j in
       step storage instructions instructions 0 (PC 0) j jrev

  -- first set of instructions we advance over
  -- second set of instructions are maintained for jump logic
  -- first JumpPairs allows lookups for ForwardJumps
  -- second JumpPairs allows lookups for BackwardJumps
  -- TODO: consider using a Reader monad to carry environment
  where step :: Tape -> [Term] -> [Term] ->
                DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->
                IO Tape
        step tape [] _ _ _ _ _ = return tape
        step tape (o:ops) os pos pc jp jpr = case o of
          IncDP -> step tape ops os (pos+1) (next pc) jp jpr
          DecDP -> step tape ops os (pos-1) (next pc) jp jpr
          OutDP -> print pos >> step tape ops os pos (next pc) jp jpr
          IncByte -> step (modAt tape pos (+1)) ops os pos (next pc) jp jpr
          DecByte -> step (modAt tape pos (subtract 1)) ops os pos (next pc) jp jpr
          OutByte -> showAt tape pos >> step tape ops os pos (next pc) jp jpr
          InByte -> do
            c <- getChar
            let b = fromIntegral $ ord c :: Word8
            step (tape // [(pos, b)]) ops os pos (next pc) jp jpr
          JumpForward -> doJump Forward tape ops os pos pc jp jpr
          JumpBackward -> doJump Backward tape ops os pos pc jp jpr

        doJump :: Direction -> Tape -> [Term] -> [Term] ->
                  DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->
                  IO Tape
        doJump dir tape ops os pos pc jp jpr =
          if shouldJump dir tape pos
          then jump tape dir os pos pc jp jpr
          else step tape ops os pos (next pc) jp jpr

        jump :: Tape -> Direction -> [Term] ->
                DataPointer -> ProgramCounter -> JumpPairs -> JumpPairs ->
                IO Tape
        jump tape dir os pos (PC pc) jp jpr = do
          let jumpTo = lookup pc (if dir == Forward then jp else jpr)
          case jumpTo of
            Nothing -> return tape
            (Just p) -> step tape (drop p os) os pos (PC p) jp jpr

        -- jump utilities
        shouldJump Forward tape pos = (tape ! pos) == 0
        shouldJump Backward tape pos = (tape ! pos) /= 0

        -- other evaluator utilities
        modAt arr pos f = arr // [(pos, f (arr ! pos))]
        showAt arr pos = putChar $ (chr . fromIntegral) (arr ! pos)
        next (PC n) = PC $ n + 1