Add support for 'roll' and 'over' instructions

app/VirtualMachine/Instruction.hs

@@ -5,7 +5,7 @@ import Data.Word (Word8)
 import System.IO (stdin, hGetChar)
 import Control.Monad.Except (throwError)
 import Control.Monad.Trans (lift, liftIO)
-import Control.Monad.Trans.Except (ExceptT, except)
+import Control.Monad.Trans.Except (ExceptT)
 import qualified Data.Map as M
 import qualified Data.Sequence as S
 
@@ -39,6 +39,7 @@ instructions = [ Simple  { _op = Nop,  _noParams = 0, _noPops = 0, _sAction = (\
                , Simple  { _op = Div,  _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y `div` x])                }
                , Simple  { _op = Neg,  _noParams = 0, _noPops = 1, _sAction = (\_ [x]    -> S.fromList [-x])                       }
                , Simple  { _op = Not,  _noParams = 0, _noPops = 1, _sAction = (\_ [x]    -> S.fromList [if x /= 0 then 0 else 1])  }
+               , Simple  { _op = Over, _noParams = 0, _noPops = 2, _sAction = (\_ [x, y] -> S.fromList [y, x, y])                  }
                , Complex { _op = Halt, _noParams = 0, _noPops = 0, _cAction = halt                                                 }
                , Complex { _op = Call, _noParams = 1, _noPops = 0, _cAction = call                                                 }
                , Complex { _op = Ret,  _noParams = 0, _noPops = 0, _cAction = ret                                                  }
@@ -53,6 +54,7 @@ instructions = [ Simple  { _op = Nop,  _noParams = 0, _noPops = 0, _sAction = (\
                , Complex { _op = In,   _noParams = 0, _noPops = 0, _cAction = input                                                }
                , Complex { _op = Out,  _noParams = 0, _noPops = 1, _cAction = output                                               }
                , Complex { _op = Clr,  _noParams = 1, _noPops = 0, _cAction = clear                                                }
+               , Complex { _op = Roll, _noParams = 0, _noPops = 0, _cAction = roll                                                 }
                ]
 
 instructionByOp :: M.Map Op Instruction
@@ -125,7 +127,7 @@ output _ (char:_) = lift $ do
   liftIO $ putStr $ [chr char]
   forward 1
   return ()
-output _ [] = except $ Left $ "Empty stack - nothing to output"
+output _ [] = throwError $ "Empty stack - nothing to output"
 
 load :: Params -> Pops -> ExceptT String Machine ()
 load (index:_) _ = do
@@ -149,4 +151,19 @@ clear (count:_) _ = lift $ do
   push top
   forward 2
   return ()
-clear [] _ = except $ Left "Number of elements to be cleaned expected"
+clear [] _ = throwError "Number of elements to be cleaned expected"
+
+roll :: Params -> Pops -> ExceptT String Machine ()
+roll _ _ = lift $ do
+  fp <- getFp
+  stackSize <- getStackSize
+  let offset = if fp == -1 then 0 else (fp + 2)
+  substack <- pop $ stackSize - offset
+  if null substack
+  then return ()
+  else do
+    let (x:xs) = substack
+    push $ xs ++ [x]
+    return ()
+  forward 1
+  return ()

app/VirtualMachine/VM.hs

@@ -41,6 +41,8 @@ data Op = Nop  -- 0x00
         | In   -- 0x16
         | Out  -- 0x17
         | Clr  -- 0x18
+        | Roll -- 0x19
+        | Over -- 0x20
         deriving (Eq, Ord, Enum, Show, Read, Bounded)
 
 type Machine = StateT VM IO

test/VirtualMachineSpec.hs

@@ -826,6 +826,141 @@ spec = do
       actual <- run input
       actual `shouldBe` expected  
 
+  describe "roll" $ do
+    it "supports stack with 5 elements" $ do
+      let input = " push 4 \n\
+                  \ push 5 \n\
+                  \ push 6 \n\
+                  \ push 7 \n\ 
+                  \ push 8 \n\               
+                  \ roll   \n\
+                  \ halt   "
+      let expected = done [7, 6, 5, 4, 8] 11 (-1)
+      actual <- run input
+      actual `shouldBe` expected     
+    it "supports stack with 4 elements" $ do
+      let input = " push 4 \n\
+                  \ push 5 \n\
+                  \ push 6 \n\
+                  \ push 7 \n\                
+                  \ roll   \n\
+                  \ halt   "
+      let expected = done [6, 5, 4, 7] 9 (-1)
+      actual <- run input
+      actual `shouldBe` expected 
+    it "supports stack with 3 elements" $ do
+      let input = " push 4 \n\
+                  \ push 5 \n\
+                  \ push 6 \n\
+                  \ roll   \n\
+                  \ halt   "
+      let expected = done [5, 4, 6] 7 (-1)
+      actual <- run input
+      actual `shouldBe` expected 
+    it "supports stack with 2 elements" $ do
+      let input = " push 4 \n\
+                  \ push 5 \n\
+                  \ roll   \n\
+                  \ halt   "
+      let expected = done [4, 5] 5 (-1)
+      actual <- run input
+      actual `shouldBe` expected 
+    it "supports singleton stack" $ do
+      let input = " push 4 \n\
+                  \ roll   \n\
+                  \ halt   "
+      let expected = done [4] 3 (-1)
+      actual <- run input
+      actual `shouldBe` expected 
+    it "supports empty stack" $ do
+      let input = " roll \n\
+                  \ halt "
+      let expected = done [] 1 (-1)
+      actual <- run input
+      actual `shouldBe` expected 
+    it "can be composed" $ do
+      let input = " push 4 \n\
+                  \ push 5 \n\
+                  \ push 6 \n\
+                  \ push 7 \n\ 
+                  \ push 8 \n\               
+                  \ roll   \n\
+                  \ roll   \n\
+                  \ roll   \n\
+                  \ halt   "
+      let expected = done [5, 4, 8, 7, 6] 13 (-1)
+      actual <- run input
+      actual `shouldBe` expected     
+    it "does not change the stack order when rolling number equals the stack size" $ do
+      let input = " push 4 \n\
+                  \ push 5 \n\
+                  \ push 6 \n\
+                  \ push 7 \n\ 
+                  \ push 8 \n\               
+                  \ roll   \n\
+                  \ roll   \n\
+                  \ roll   \n\
+                  \ roll   \n\
+                  \ roll   \n\
+                  \ halt   "
+      let expected = done [8, 7, 6, 5, 4] 15 (-1)
+      actual <- run input
+      actual `shouldBe` expected       
+    it "works in the context of current frame" $ do
+      let input = "      push 1    \n\
+                  \      push 2    \n\
+                  \      push 3    \n\
+                  \      call &foo \n\
+                  \ foo: push 10   \n\
+                  \      push 20   \n\
+                  \      push 30   \n\
+                  \      call &bar \n\
+                  \ bar: push 70   \n\
+                  \      push 80   \n\
+                  \      push 90   \n\
+                  \      roll      \n\
+                  \      halt      "
+      let expected = done [80, 70, 90, 16, 3, 30, 20, 10, 8, -1, 3, 2, 1] 23 8
+      --                   ├────────┤         ├────────┤         ├─────┤
+      --                   │        │         │        │         └─────┴── there are no 'roll' instructions under the root so the data is in the correct order
+      --                   │        │         └────────┴────────────────── as above - no 'roll' instruction under the 'foo' function
+      --                   └────────┴───────────────────────────────────── the 'roll' instruction is called under the 'bar' function, so the numbers are rolled  
+      actual <- run input
+      actual `shouldBe` expected      
+
+  describe "over" $ do
+    it "pushes the second value from the top" $ do
+      let input = " push 1 \n\
+                  \ push 2 \n\
+                  \ over   \n\
+                  \ halt   "
+      let expected = done [1, 2, 1] 5 (-1)
+      actual <- run input
+      actual `shouldBe` expected  
+    it "can be used multiple times" $ do
+      let input = " push 1 \n\
+                  \ push 2 \n\
+                  \ over   \n\
+                  \ over   \n\
+                  \ over   \n\
+                  \ halt   "
+      let expected = done [1, 2, 1, 2, 1] 7 (-1)
+      actual <- run input
+      actual `shouldBe` expected  
+    it "raises error if empty stack" $ do
+      let input = " over \n\
+                  \ halt "
+      let expected = Left "Attempt to pop from empty stack: tried to pop 2 elements, got 0"
+      actual <- run input
+      actual `shouldBe` expected           
+    it "raises error if stack is not big enough" $ do
+      let input = " push 5 \n\
+                  \ over   \n\
+                  \ halt   "
+      let expected = Left "Attempt to pop from empty stack: tried to pop 2 elements, got 1"
+      actual <- run input
+      actual `shouldBe` expected    
+
   describe "examples" $ do
     it "example #1" $ do
       let input = " main: push 2    \n\