Split VirtualMachine module

app/VirtualMachine/Interpreter.hs

@@ -0,0 +1,88 @@
+module VirtualMachine.Interpreter where
+
+import Data.Word (Word8)
+import Control.Monad.Trans.Except (ExceptT, except)
+import Control.Monad.State (runState, execState)
+import qualified Data.Map as M
+import qualified Data.ByteString as B
+
+import VirtualMachine.VM (VM(..), Op, empty, pop, pushS, forward, getPc)
+import VirtualMachine.Instruction (Instruction(..), Unit(..), instructionByOp)
+
+
+parseInstr :: [Word8] -> Either String (Instruction, [Word8])
+parseInstr (opCode:rest) = do
+  let op = toEnum . fromIntegral $ opCode :: Op
+  instr <- case M.lookup op instructionByOp of
+    (Just i) -> Right i
+    Nothing -> Left "Unknown instruction"
+  let noParams = _noParams instr
+  let params = map fromIntegral $ take noParams rest :: [Word8]
+  if length params == noParams 
+  then return (instr, params)
+  else Left $ "Expected " ++ (show noParams) ++ " parameter(s), got " ++ (show $ length params) ++ " for operator '" ++ (show op) ++ "'"
+parseInstr [] = Left "Unexpected end of the file"
+
+
+parse :: [Word8] -> Either String [Unit]
+parse [] = Right []
+parse code = do
+  (instr, params) <- parseInstr code
+  let paramBytes = map Byte params
+  let noParams = _noParams instr
+  rest <- parse (drop (noParams + 1) code)
+  return $ [Instr instr] ++ paramBytes ++ rest
+
+interpret :: VM -> [Unit] -> ExceptT String IO VM
+interpret vm@VM { _halt = True} _ = except $ Right $ vm
+interpret vm units = do
+  vm' <- interpretUnit vm units
+  interpret vm' units
+
+interpretUnit :: VM -> [Unit] -> ExceptT String IO VM
+interpretUnit _ [] = except $ Left "Nothing to interpret"
+interpretUnit vm units
+  | pc >= progSize = except $ Left $ "PC (=" ++ (show pc) ++ ") exceeds program size (=" ++ (show progSize) ++ ")"
+  | otherwise = case unit of
+      (Instr instr) -> dispatchInstr vm units instr
+      (Byte _)      -> except $ Left $ "PC (=" ++ (show pc) ++ ") currently points to the data byte rather than instruction" 
+  where
+    pc = _pc vm
+    progSize = length units
+    unit = units !! pc
+
+dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM
+dispatchInstr vm units instr = case instr of 
+  Simple {} -> except $ Right $ interpretSimple vm units instr 
+  Complex {} -> interpretComplex vm units instr 
+
+interpretSimple :: VM -> [Unit] -> Instruction -> VM
+interpretSimple vm units instr = flip execState vm $ do    
+  pc <- getPc
+  let noParams = _noParams instr  
+  let noPops = _noPops instr        
+  let paramBytes = take noParams $ drop (pc + 1) $ units
+  let params = map (fromIntegral . _byte) paramBytes    
+  let action = _sAction instr
+  pops <- pop noPops
+  let pushes = action params pops
+  pushS pushes
+  forward $ noParams + 1
+  return ()
+    
+
+interpretComplex :: VM -> [Unit] -> Instruction -> ExceptT String IO VM
+interpretComplex vm units instr = action vm' params pops
+  where    
+    pc = _pc vm
+    noParams = _noParams instr  
+    noPops = _noPops instr  
+ 
+    paramBytes = take noParams $ drop (pc + 1) $ units 
+    params = map (fromIntegral . _byte) paramBytes     
+    (pops, vm') = runState (pop noPops) vm
+
+    action = _cAction instr
+    
+run :: B.ByteString -> ExceptT String IO VM
+run code = (return $ B.unpack code) >>= (except . parse) >>= interpret empty