Create emitter

MVM.cabal

@@ -30,6 +30,7 @@ executable MVM
       VirtualMachine
       Assembler.Tokenizer
       Assembler.Parser
+      Assembler.Emitter
       Util
 
     -- LANGUAGE extensions used by modules in this package.
@@ -37,7 +38,8 @@ executable MVM
     build-depends:
       base ^>=4.15.0.0,
       bytestring ^>=0.11.0.0,
-      containers ^>=0.6.4.1
+      containers ^>=0.6.4.1,
+      mtl ^>=2.2.2
       
     hs-source-dirs:   app
     default-language: Haskell2010
@@ -52,16 +54,19 @@ test-suite spec
   build-depends:
       base ^>=4.15.0.0,
       bytestring ^>=0.11.0.0,
-      containers ^>=0.6.4.1
-    , hspec ==2.*
+      containers ^>=0.6.4.1, 
+      mtl ^>=2.2.2,
+      hspec ==2.*
   other-modules:      
       Assembler.TokenizerSpec  
       Assembler.ParserSpec
+      Assembler.EmitterSpec
       UtilSpec
 
       VirtualMachine
       Assembler.Tokenizer
       Assembler.Parser
+      Assembler.Emitter
       Util          
         
   default-language: Haskell2010

app/Assembler/Emitter.hs

@@ -0,0 +1,78 @@
+module Assembler.Emitter where
+
+import Control.Monad.State
+import Data.Word (Word8)
+
+import qualified Data.Map as M
+
+import Assembler.Parser (AST(..))
+
+
+data Bean = Byte Word8 
+          | Reference String
+          deriving (Show, Eq)
+
+data Context = Context { _beans   :: [Bean]
+                       , _labels  :: M.Map String Int 
+                       } deriving (Show, Eq)
+type Emitter = AST -> State Context ()
+
+empty :: Context
+empty = Context { _beans = [], _labels = M.fromList [] }
+
+emitLabelDef :: Emitter
+emitLabelDef (LabelDef label) = do
+  ctx <- get
+  let labels = _labels ctx
+  let current = length (_beans ctx)
+  put ctx { _labels = M.insert label current labels }
+  return ()
+
+emitParam :: Emitter
+emitParam (Param (Integer x)) = emitByte $ fromIntegral $ x
+emitParam (Param (LabelRef label)) = emitBean $ Reference $ label
+
+emitInstr :: Emitter
+emitInstr (Instruction (Operator op) Empty) = emitByte $ fromIntegral . fromEnum $ op
+emitInstr (Instruction (Operator op) (Params params)) = do
+  emitByte $ fromIntegral . fromEnum $ op
+  mapM emitParam params 
+  return ()
+
+emitLine :: Emitter
+emitLine (Line labelDef Empty) = emitLabelDef labelDef
+emitLine (Line Empty instr) = emitInstr instr
+emitLine (Line labelDef instr) = emitLabelDef labelDef >> emitInstr instr >> return ()
+
+emitProgram :: Emitter
+emitProgram (Program progLines) = mapM emitLine progLines >> return ()
+
+emitByte :: Word8 -> State Context ()
+emitByte byte = emitBean $ Byte $ byte
+
+emitBean :: Bean -> State Context ()
+emitBean bean = do
+  ctx <- get
+  put ctx { _beans = _beans ctx ++ [bean] }
+  return ()
+
+resolveLabels :: M.Map String Int -> [Bean] -> Either String [Bean]
+resolveLabels labels beans = sequence $ foldr folder [] beans
+  where
+    folder b acc = (resolveLabel labels b) : acc
+
+resolveLabel :: M.Map String Int -> Bean -> Either String Bean
+resolveLabel labels b@(Byte _) = Right b
+resolveLabel labels (Reference label) = case M.lookup label labels of
+    (Just t) -> Right . Byte . fromIntegral $ t
+    Nothing  -> Left $ "Label '" ++ label ++ "' is not defined"  
+
+emit :: AST -> Either String [Word8]
+emit root = do  
+  let ctx = execState (emitProgram root) empty
+  let labels = _labels ctx
+  let beans = _beans ctx
+  resolved <- resolveLabels labels beans
+  return $ map (\(Byte b) -> b) resolved  
+    
+  

test/Assembler/EmitterSpec.hs

@@ -0,0 +1,47 @@
+module Assembler.EmitterSpec where
+
+import Test.Hspec
+
+import qualified Data.Map as M
+
+
+import Assembler.Tokenizer (tokenize)
+import Assembler.Parser (parse)
+import Assembler.Emitter
+
+spec :: Spec
+spec = do
+  describe "resolveLabels" $ do
+    it "replaces reference with actual byte number" $ do
+      let beans = [ Byte 1, Byte 2, Reference "main", Byte 4 ]
+      let labels = M.fromList [("main", 3)]
+      resolveLabels labels beans `shouldBe` Right [Byte 1, Byte 2, Byte 3, Byte 4]
+    it "throws error if label does not exist" $ do
+      let beans = [ Byte 1, Byte 2, Reference "not_existing_label", Byte 4 ]
+      let labels = M.fromList [("main", 3)]
+      resolveLabels labels beans `shouldBe` Left "Label 'not_existing_label' is not defined"
+
+  describe "emit" $ do
+    it "label resolution works" $ do
+      let input = "main: \n\
+                  \push 1\n\
+                  \push 2\n\
+                  \jmp &sum\n\
+                  \\n\
+                  \sum: add\n\
+                  \jmp &main"      
+      let (Right tokens) = tokenize input
+      let (Right ast) = parse tokens
+      let expected = [0x02, 0x01, 0x02, 0x02, 0x0e, 0x06, 0x06, 0x0e, 0x00]
+      emit ast `shouldBe` Right expected
+    it "raises error if label has not been defined" $ do
+      let input = "main: \n\
+                  \push 1\n\
+                  \push 2\n\
+                  \jmp &sum\n\
+                  \\n\
+                  \sum: add\n\
+                  \jmp &program"      
+      let (Right tokens) = tokenize input
+      let (Right ast) = parse tokens      
+      emit ast `shouldBe` Left "Label 'program' is not defined"