new executable vmcompiler: compiles vm code to hack assembly

app/VMCompiler.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import           Control.Monad         (forM_)
+import qualified Data.Text.IO          as TIO
+import           Nand2Tetris.Hack      (AsmLine (..), HackInstruction (..),
+                                        canonicalRepresentation)
+import           Nand2Tetris.VM        (AnnotatedAsmLine (..),
+                                        compileInstructions, parseInstructions)
+import           Options.Applicative   (execParser, fullDesc, header, help,
+                                        helper, info, long, metavar, progDesc,
+                                        short, strOption, (<**>))
+import           System.IO             (IOMode (WriteMode), hPutStrLn, withFile)
+import           Text.Megaparsec       (runParser)
+import           Text.Megaparsec.Error (ParseErrorBundle,
+                                        ShowErrorComponent (showErrorComponent),
+                                        errorBundlePretty)
+
+data Options =
+  Options
+  {
+    inputFile  :: FilePath,
+    outputFile :: FilePath
+  }
+
+main :: IO ()
+main = do
+  options <- execParser opts
+  programText <- TIO.readFile (inputFile options)
+  let result = runParser parseInstructions (inputFile options) programText
+  case result of
+    Left err -> putStrLn $ errorBundlePretty err
+    Right parsed -> do
+      let compiled = compileInstructions parsed
+      withFile (outputFile options) WriteMode $ \h -> forM_ compiled (\x -> TIO.hPutStrLn h (printLine x))
+  where
+    printLine (Comment t) = "// " <> t
+    printLine (Code i)    = canonicalRepresentation (LineInstruction i)
+    printLine (ALabel l)  = canonicalRepresentation (LineLabel l)
+
+    opts = info (hackAsmOptParser <**> helper)
+             ( fullDesc
+            <> progDesc "Compiles Hack VM code to Hack assembly"
+            <> header "vmcompiler - Hack VM compiler (nand2tetris)" )
+    hackAsmOptParser = Options <$>
+      strOption ( long "input"
+               <> short 'i'
+               <> metavar "FILENAME"
+               <> help "Input file" ) <*>
+      strOption ( long "output"
+               <> short 'o'
+               <> metavar "FILENAME"
+               <> help "Output file" )

nand2tetris.cabal

@@ -25,6 +25,18 @@ executable hackasm
                      , containers
                      , bytestring
 
+executable vmcompiler
+  hs-source-dirs:      app
+  main-is:             VMCompiler.hs
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , nand2tetris
+                     , text
+                     , megaparsec
+                     , optparse-applicative
+                     , containers
+                     , bytestring
+
 library
   hs-source-dirs:      src
   default-language:    Haskell2010

src/Nand2Tetris/Hack.hs

@@ -15,7 +15,8 @@ module Nand2Tetris.Hack
     LabelMap,
     Error(..),
     addVars,
-    addLabels
+    addLabels,
+    canonicalRepresentation
   ) where
 
 import           Control.Monad              (forM, when)
@@ -95,6 +96,52 @@ data AsmLine =
   | LineLabel T.Text
   deriving (Show, Eq)
 
+canonicalRepresentation :: AsmLine -> T.Text
+canonicalRepresentation (LineLabel t) = "(" <> t <> ")"
+canonicalRepresentation (LineInstruction (A (Label t))) = "@" <> t
+canonicalRepresentation (LineInstruction (A (Imm v))) = "@" <> (T.pack . show) v
+canonicalRepresentation (LineInstruction (C dest src jmp)) = destRepr <> srcRepr src <> jmpRepr
+  where
+    regRepr RegM = "M"
+    regRepr RegA = "A"
+    regRepr RegD = "D"
+
+    destRepr = if null dest
+      then ""
+      else T.pack (concatMap regRepr dest) <> "="
+
+    srcRepr S0 = "0"
+    srcRepr S1 = "1"
+    srcRepr SNeg1 = "-1"
+    srcRepr (SReg r) = regRepr r
+    srcRepr (SNot r) = "!" <> regRepr r
+    srcRepr (SNeg r) = "-" <> regRepr r
+    srcRepr (SRegPlus1 r) = regRepr r <> "+1"
+    srcRepr (SRegMinus1 r) = regRepr r <> "-1"
+    srcRepr SDPlusA = "D+A"
+    srcRepr SDPlusM = "D+M"
+    srcRepr SDMinusA = "D-A"
+    srcRepr SDMinusM = "D-M"
+    srcRepr SAMinusD = "A-D"
+    srcRepr SMMinusD = "M-D"
+    srcRepr SDAndA = "D&A"
+    srcRepr SDAndM = "D&M"
+    srcRepr SDOrA = "D|A"
+    srcRepr SDOrM = "D|M"
+
+    jmpRepr = if jmp == JNone
+      then ""
+      else "; " <> jmpRepr' jmp
+
+    jmpRepr' JNone = ""
+    jmpRepr' JGt = "JGT"
+    jmpRepr' JEq = "JEQ"
+    jmpRepr' JGe = "JGE"
+    jmpRepr' JLt = "JLT"
+    jmpRepr' JNe = "JNE"
+    jmpRepr' JLe = "JLE"
+    jmpRepr' Jmp = "JMP"
+
 hackParser :: Parser [AsmLine]
 hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
   where

src/Nand2Tetris/VM.hs

@@ -9,13 +9,16 @@ module Nand2Tetris.VM
     Segment(..),
     AnnotatedAsmLine(..),
     parseInstruction,
+    parseInstructions,
     compileInstruction,
+    compileInstructions,
     defaultCompilerEnv,
     runCompiler,
     runCompilerDef
   ) where
 
-import           Control.Monad.State.Strict (State, evalState, gets, modify')
+import           Control.Monad.State.Strict (State, evalState, forM, gets,
+                                             modify')
 import           Data.Functor               (($>))
 import qualified Data.Text                  as T
 import           Nand2Tetris.Error          (Error)
@@ -23,11 +26,13 @@ import           Nand2Tetris.Hack           (HackInstruction (A, C),
                                              Imm (Imm, Label),
                                              Jump (JEq, JGt, JLt, JNone, Jmp),
                                              Reg (RegA, RegD, RegM),
-                                             Source (S0, SDAndM, SDOrM, SDPlusA, SDPlusM, SMMinusD, SNeg, SNeg1, SNot, SReg, SRegMinus1, SRegPlus1))
+                                             Source (S0, SDAndM, SDOrM, SDPlusA, SDPlusM, SMMinusD, SNeg, SNeg1, SNot, SReg, SRegMinus1, SRegPlus1),
+                                             canonicalRepresentation)
 import           Text.Megaparsec            (MonadParsec (try), Parsec, choice,
-                                             many, (<|>))
+                                             empty, eof, many, (<|>))
 import           Text.Megaparsec.Char       (alphaNumChar, char, letterChar,
                                              space1, string)
+import           Text.Megaparsec.Char.Lexer (skipLineComment)
 import qualified Text.Megaparsec.Char.Lexer as L
 
 data VMInstruction =
@@ -96,6 +101,12 @@ instrAnnotation (VMMemAccess accessType segment) =
 
 type Parser = Parsec Error T.Text
 
+parseInstructions :: Parser [VMInstruction]
+parseInstructions = many (sp *> parseInstruction <* sp) <* eof
+  where
+    sp :: Parser ()
+    sp = L.space space1 (skipLineComment "//") empty
+
 parseInstruction :: Parser VMInstruction
 parseInstruction =
   try parseMemAccess <|>
@@ -179,6 +190,9 @@ runCompiler = flip evalState
 runCompilerDef :: Compiler a -> a
 runCompilerDef = runCompiler defaultCompilerEnv
 
+compileInstructions :: [VMInstruction] -> [AnnotatedAsmLine]
+compileInstructions instrs = concat $ runCompilerDef (forM instrs compileInstruction)
+
 compileInstruction :: VMInstruction -> Compiler [AnnotatedAsmLine]
 compileInstruction instr = do
   let ann = Comment (instrAnnotation instr)