{-# LANGUAGE FlexibleInstances #-}
{- |
Module : HaskBF.Tape
Description : Implement the brainfuck tape
Copyright : (c) Sebastian Galkin, 2014
License : MIT
Maintainer : paraseba@gmail.com
Stability : experimental
Provides a type and operations to implement the brainfuck tape. The tape has
the concept of a pointer, and the pointer can be incremented or decremented.
-}
module HaskBF.Tape (
Tape (Tape)
, ExecutionError (errMsg, errTape)
, rTape, wTape
, inc, dec
, right, left
, BFExError
, BFTape
, blankTape
) where
import Data.Int
( Int8 )
import Control.Monad.Error
( Error, strMsg )
{- | Brainfuck tape. Constructor arguments correspond to
-
- 1. left of the current pointer
- 2. current pointed value
- 3. right of the current pointer
-
- The left part of the tape is reversed, so the first element of the list
- is the rightmost position. The right list is normal order, its first element
- is the leftmost one. -}
data Tape t = Tape [t] t [t]
deriving (Show)
-- | Write element to the current position in the tape
wTape :: t -- ^ The element to write
-> Tape t -- ^ The tape
-> Tape t -- ^ The modified tape
wTape b (Tape l _ r) = Tape l b r
-- | Read the pointed element
rTape :: Tape t -- ^ The tape
-> t -- ^ The element currently pointed by the pointer
rTape (Tape _ current _) = current
update :: (t -> t) -> Tape t -> Tape t
update f t = wTape (f $ rTape t) t
-- | Increment the currently pointed element
inc :: Num a
=> Tape a -- ^ The tape
-> Tape a -- ^ The tape with the current position incremented
inc = update (+ 1)
-- | Decrement the currently pointed element
dec :: Num a
=> Tape a -- ^ The tape
-> Tape a -- ^ The tape with the current position decremented
dec = update (+ (- 1))
{- | Type for execution errors, trying to move the tape beyond one of its
- ends. The 'String' argument is the error message and the 'Tape' is in
- the state right before the faulting operation -}
data ExecutionError a = ExecutionError {errMsg :: String, errTape :: Tape a}
-- | Move the pinter to the right
right :: Tape a -- ^ The tape
-> Either (ExecutionError a) (Tape a)
{- ^ A new tape with its pointer pointing to the
- element to the right of the pointer in the
- original tape; or an execution error if the
- tape to the right is exhausted -}
right t@(Tape _ _ []) =
Left $ ExecutionError "Error trying to go right on an empty tape" t
right (Tape l c (r : rs)) = Right $ Tape (c : l) r rs
-- | Move the pinter to the left
left :: Tape a -- ^ The tape
-> Either (ExecutionError a) (Tape a)
{- ^ A new tape with its pointer pointing to
- the element to the left of the pointer in
- the original tape; or an execution error if
- the tape to the left is exhausted -}
left t@(Tape [] _ _) =
Left $ ExecutionError "Error trying to go left on an empty tape" t
left (Tape (l : ls) c r) = Right $ Tape ls l (c : r)
constTape :: t -> Tape t
constTape b = Tape [] b (repeat b)
-- | Execution error type for basic Brainfuck tapes
type BFExError = ExecutionError Int8
-- | Brainfuck tapes type
type BFTape = Tape Int8
instance Error BFExError where
strMsg s = ExecutionError s (Tape [] 0 [])
{- | A @(0 :: 'Int8')@ initialized, infinite 'Tape' pointing to its
- leftmost position. An attemp to move the pointer left will result
- in an error -}
blankTape :: BFTape
blankTape = constTape 0