Written run function

src/Interpreter.hs

@@ -2,6 +2,7 @@
 
 module Interpreter where
 import Data.Maybe (catMaybes)
+import Control.Monad (liftM, ap)
 
 data Instruction = TapeLeft | TapeRight | Add | Sub | Out | In | LoopStart | LoopEnd
     deriving (Eq, Show)
@@ -32,12 +33,26 @@ decr (Byte i) = Byte (i - 1)
 type Tape = [Byte]
 type Program = [Instruction]
 
-data ProgState = ProgState {
+data State = State {
     tape :: Tape,
     dp :: Int,
     output :: String,
     program :: Program,
-    ip :: Int }
+    ip :: Int } deriving (Show)
+
+data Execution a = Working a | Crash Error | Done String deriving (Show)
+
+instance Monad Execution where
+    (Crash e) >>= _ = Crash e
+    (Done t) >>= _ = Done t
+    (Working d) >>= f = f d
+
+instance Functor Execution where
+    fmap = liftM
+
+instance Applicative Execution where
+    pure = return
+    (<*>) = ap
 
 toProgram :: String -> [Instruction]
 toProgram s = catMaybes $ fmap parseInstr s
@@ -46,33 +61,33 @@ tapeHelp :: Tape -> Int -> (Byte -> Byte) -> Tape
 tapeHelp (t:tt) 0 alter = alter t : tt
 tapeHelp (t:tt) dp alter = t : (tapeHelp tt dp alter)
 
-data Error = NegTape | LoopNoMatch
+data Error = NegTape | LoopNoMatch deriving (Show)
 
 errorDesc :: Error -> String
 errorDesc NegTape = "ERROR: '<' not working. Cannot access negative tape positions."
 errorDesc LoopNoMatch = "ERROR: '[' or ']' not working. Matching parenthesis not found."
 
-incrIP :: ProgState -> ProgState
+incrIP :: State -> State
 incrIP p = p { ip = ip p + 1 }
 
-execAdd :: ProgState -> Either Error ProgState
-execAdd p = Right p { tape = newTape }
+execAdd :: State -> Execution State
+execAdd p = Working p { tape = newTape }
     where newTape = tapeHelp (tape p) (dp p) incr
 
-execSub :: ProgState -> Either Error ProgState
-execSub p = Right p { tape = newTape }
+execSub :: State -> Execution State
+execSub p = Working p { tape = newTape }
     where newTape = tapeHelp (tape p) (dp p) decr
 
-execTapeLeft :: ProgState -> Either Error ProgState
-execTapeLeft p = case dp p of 0 -> Left NegTape
-                              n -> Right p { dp = n - 1 }
+execTapeLeft :: State -> Execution State
+execTapeLeft p = case dp p of 0 -> Crash NegTape
+                              n -> Working p { dp = n - 1 }
 
-execTapeRight :: ProgState -> Either Error ProgState
-execTapeRight p = Right p { tape = if endOfType then tape p ++ [Byte 0] else tape p }
+execTapeRight :: State -> Execution State
+execTapeRight p = Working p { tape = if endOfType then tape p ++ [Byte 0] else tape p }
     where endOfType = dp p == length (tape p) - 1
 
-execOut :: ProgState -> Either Error ProgState
-execOut p = Right p { output = output p ++ [chr char]}
+execOut :: State -> Execution State
+execOut p = Working p { output = output p ++ [chr char]}
     where char = (tape p) !! dp p
 
 data WalkingDirection = Forward | Backward
@@ -91,35 +106,39 @@ findMatching prg start wd = case wd of
                 | otherwise          = fmHelper (upd s) acc b ob upd limit
                 where c = prg !! start
 
-execLoop :: WalkingDirection -> ProgState -> Either Error ProgState
+execLoop :: WalkingDirection -> State -> Execution State
 execLoop d w = case posOrF of
-            Just n -> Right w { ip = n }
-            Nothing -> Left LoopNoMatch
+            Just n -> Working w { ip = n }
+            Nothing -> Crash LoopNoMatch
     where jump = (tape w !! dp w) == Byte 0
           posOrF = if jump then findMatching (program w) (ip w) d else Just $ ip w
 
-executeInstruction :: Instruction -> ProgState -> Either Error ProgState
-executeInstruction w = (fmap incrIP) . case (program w !! ip w) of
-    TapeLeft -> execTapeLeft
-    TapeRight -> execTapeRight
-    Add -> execAdd
-    Sub -> execSub
-    Out -> execOut
-    LoopStart -> execLoop Forward
-    LoopEnd -> execLoop Backward $ w
+execute :: State -> Execution State
+execute w = runInstr w >>= checkDone >>= execute
+    where instrFor w = case (program w !! ip w) of
+                TapeLeft -> execTapeLeft
+                TapeRight -> execTapeRight
+                Add -> execAdd
+                Sub -> execSub
+                Out -> execOut
+                LoopStart -> execLoop Forward
+                LoopEnd -> execLoop Backward
 
-newtype Executor a = Ee Either String a
-instance Executor Monad where
-    `<<=` :: Executor a -> (a -> Executor a) -> Executor A
-    (Ee a) <<= k = case a of
-                        Left c -> Ee (Left c)
-                        Right b -> k
-    return :: a -> Executor a
-    return a = Ee (Left a)
-    fail :: String -> Executor a
-    fail c = Ee (Right c)
-
-executeInstruction
+          runInstr :: State -> Execution State
+          runInstr w = instrFor w $ w
 
+          checkDone :: State -> Execution State
+          checkDone ps
+            | length (program ps) == ip ps = Done $ output ps
+            | otherwise                    = Working $ incrIP ps
 
+initState :: Program -> State
+initState p = State {
+    tape = [Byte 0],
+    dp = 0,
+    output = "",
+    program = p,
+    ip = 0}
 
+run :: String -> Execution State
+run = execute . initState . catMaybes . fmap parseInstr