Create print-based VM debugger

app/Main.hs

@@ -3,13 +3,13 @@ module Main where
 import System.Environment
 import Control.Monad.Trans.Except (runExceptT, except)
 
-import VirtualMachine.VM (VM)
+import VirtualMachine.VM (VM(..), empty)
 import VirtualMachine.Interpreter (run)
 import Assembler.Compiler (compile)
 import qualified Data.ByteString as B
 
 interpret :: String -> IO (Either String VM)
-interpret input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= run
+interpret input = runExceptT $ (except $ return $ input) >>= (except . compile) >>= (except . return . B.pack) >>= run empty { _debug = False }
   
 main :: IO ()
 main = do

app/VirtualMachine/Instruction.hs

@@ -48,8 +48,8 @@ instructions = [ Simple  { _op = Nop,  _noParams = 0, _noPops = 0, _sAction = (\
                , Complex { _op = Jl,   _noParams = 1, _noPops = 1, _cAction = jumpIf (<)                                           }
                , Complex { _op = Jge,  _noParams = 1, _noPops = 1, _cAction = jumpIf (>=)                                          }
                , Complex { _op = Jle,  _noParams = 1, _noPops = 1, _cAction = jumpIf (<=)                                          }
+               , Complex { _op = In,   _noParams = 0, _noPops = 0, _cAction = niy In                                               }
                , Complex { _op = Out,  _noParams = 0, _noPops = 1, _cAction = output                                               }
-               , Complex { _op = Dbg,  _noParams = 0, _noPops = 0, _cAction = debug                                                }
                ]
 
 instructionByOp :: M.Map Op Instruction
@@ -81,11 +81,6 @@ ret vm _ _ = do
   
   return vm { _fp = fp', _pc = retAddr, _stack = stack' }     
 
-debug :: VM -> Params -> Pops -> ExceptT String IO VM
-debug vm _ _ = do
-  liftIO $ print vm
-  return vm { _pc = _pc vm + 1 }
-
 jumpIf :: (Int -> Int -> Bool) -> VM -> Params -> Pops -> ExceptT String IO VM
 jumpIf predicate vm (addr:_) (top:_) = except $ Right $ vm { _pc = pc }
   where pc = if top `predicate` 0 then addr else _pc vm + 2
@@ -97,3 +92,6 @@ output vm _ (char:_) = do
   liftIO $ putStr $ [chr char]
   return (execState (forward 1) vm)  
 output _ _ [] = except $ Left $ "Empty stack - nothing to output"
+
+niy :: Op -> VM -> Params -> Pops -> ExceptT String IO VM
+niy op vm _ _ = except $ Left $ "Instruction '" ++ (show op) ++ "' ("++ (show $ _pc vm) ++") is not implemented yet"

app/VirtualMachine/Interpreter.hs

@@ -1,8 +1,9 @@
 module VirtualMachine.Interpreter where
 
 import Data.Word (Word8)
+import Data.List (intercalate)
 import Control.Monad.Trans.Except (ExceptT, except)
-import Control.Monad.State (runState, execState)
+import Control.Monad.State (liftIO, runState, execState)
 import qualified Data.Map as M
 import qualified Data.ByteString as B
 
@@ -52,9 +53,23 @@ interpretUnit vm units
     unit = units !! pc
 
 dispatchInstr :: VM -> [Unit] -> Instruction -> ExceptT String IO VM
-dispatchInstr vm units instr = case instr of 
+dispatchInstr vm units instr = do
-  Simple {} -> except $ Right $ interpretSimple vm units instr 
+  liftIO $ debugPrint vm instr units
-  Complex {} -> interpretComplex vm units instr 
+
+  case instr of 
+    Simple {}  -> except $ Right $ interpretSimple vm units instr 
+    Complex {} -> interpretComplex vm units instr
+
+debugPrint :: VM -> Instruction -> [Unit] -> IO ()
+debugPrint vm instr units = if _debug vm
+           then do
+             let pc = _pc vm
+             let noParams = _noParams instr
+             let params = intercalate "" $ map (show . _byte) $ take noParams $ drop (pc + 1) $ units
+             putStrLn $ show vm
+             putStrLn $ (show pc) ++ ": " ++ (show $ _op instr) ++ " " ++ params
+             return ()
+           else return ()
 
 interpretSimple :: VM -> [Unit] -> Instruction -> VM
 interpretSimple vm units instr = flip execState vm $ do    
@@ -84,5 +99,8 @@ interpretComplex vm units instr = action vm' params pops
 
     action = _cAction instr
     
-run :: B.ByteString -> ExceptT String IO VM
+run :: VM -> B.ByteString -> ExceptT String IO VM
-run code = (return $ B.unpack code) >>= (except . parse) >>= interpret empty
+run vm code = (return $ B.unpack code) >>= (except . parse) >>= interpret vm
+
+runEmpty :: B.ByteString -> ExceptT String IO VM
+runEmpty = run empty

app/VirtualMachine/VM.hs

@@ -6,10 +6,11 @@ import Control.Monad.Trans.Except (ExceptT, except)
 import qualified Data.Sequence as S
 
 
-data VM = VM { _pc :: Int
+data VM = VM { _pc    :: Int
-             , _fp :: Int
+             , _fp    :: Int
              , _stack :: S.Seq Int
-             , _halt :: Bool
+             , _halt  :: Bool
+             , _debug :: Bool
              } deriving (Show, Eq)
 
 data Op = Nop  -- 0x00 
@@ -36,7 +37,6 @@ data Op = Nop  -- 0x00
         | Ld   -- 0x15
         | In   -- 0x16
         | Out  -- 0x17
-        | Dbg  -- 0x18
         deriving (Eq, Ord, Enum, Show, Read, Bounded)
 
 empty :: VM
@@ -44,6 +44,7 @@ empty = VM { _pc     = 0
            , _fp     = -1
            , _stack  = S.empty
            , _halt   = False
+           , _debug  = False
            }
 
 -------------------------------------------------------------------------------