Compile push instructions

src/Nand2Tetris/VM.hs

@@ -1,25 +1,28 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module Nand2Tetris.VM
   (
     VMInstruction(..),
     ArithmeticCmd(..),
     AccessType(..),
-    SegmentOffset(..),
-    SegmentId(..),
-    parseInstruction
+    Segment(..),
+    AnnotatedAsmLine(..),
+    parseInstruction,
+    compileInstruction
   ) where
 
 import Nand2Tetris.Error ( Error )
-import Text.Megaparsec (Parsec, MonadParsec (try), (<|>), choice)
+import Text.Megaparsec (Parsec, MonadParsec (try), (<|>), choice, many)
 import qualified Data.Text as T
-import Text.Megaparsec.Char (string, space1)
+import Text.Megaparsec.Char (string, space1, letterChar, alphaNumChar, char)
 import Data.Functor (($>))
 import qualified Text.Megaparsec.Char.Lexer as L
+import Nand2Tetris.Hack (HackInstruction (A, C), Imm (Label, Imm), Reg (RegD, RegA, RegM), Source (SReg, SDPlusA, SRegPlus1), Jump (JNone))
 
 data VMInstruction =
     VMArithmetic ArithmeticCmd
-  | VMMemAccess AccessType SegmentId SegmentOffset
+  | VMMemAccess AccessType Segment
   deriving (Show, Eq)
 
 data ArithmeticCmd =
@@ -39,20 +42,40 @@ data AccessType =
   | ACPop
   deriving (Show, Eq)
 
-newtype SegmentOffset = SegmentOffset { unSegmentOffset :: Int }
-  deriving (Show, Eq)
+--newtype SegmentOffset = SegmentOffset { unSegmentOffset :: Int }
+--  deriving (Show, Eq)
 
-data SegmentId =
-    SLocal
-  | SArgument
-  | SThis
-  | SThat
-  | SConstant
-  | SStatic
-  | SPointer
-  | STemp
+data Segment =
+    SLocal Int
+  | SArgument Int
+  | SThis Int
+  | SThat Int
+  | SConstant Int
+  | SStatic T.Text
+  | SPointer Int
+  | STemp Int
   deriving (Show, Eq)
 
+instrAnnotation :: VMInstruction -> T.Text
+instrAnnotation (VMArithmetic i) = ""
+instrAnnotation (VMMemAccess accessType segment) =
+  strAccessType <> " " <> strSegment
+  where
+    strAccessType = case accessType of
+      ACPush -> "push"
+      ACPop -> "pop"
+
+    strSegment = case segment of
+      SLocal i -> "local " <> (T.pack . show $ i)
+      SArgument i -> "argument " <> (T.pack . show $ i)
+      SThis i -> "this " <> (T.pack . show $ i)
+      SThat i -> "that " <> (T.pack . show $ i)
+      SConstant i -> "constant " <> (T.pack . show $ i)
+      SStatic label -> "static " <> label
+      SPointer i -> "pointer " <> (T.pack . show $ i)
+      STemp i -> "temp " <> (T.pack . show $ i)
+
+
 type Parser = Parsec Error T.Text
 
 parseInstruction :: Parser VMInstruction
@@ -64,27 +87,37 @@ parseInstruction =
     parseMemAccess :: Parser VMInstruction
     parseMemAccess = VMMemAccess <$>
       parseAccessType <*>
-      parseSegmentId <*>
-      parseSegmentOffset
+      parseSegment
 
     parseAccessType :: Parser AccessType
     parseAccessType = try (string "push" >> space1 $> ACPush) <|>
       (string "pop" >> space1 $> ACPop)
 
-    parseSegmentId :: Parser SegmentId
-    parseSegmentId =
-      choice [ string "local" $> SLocal,
-               string "argument" $> SArgument,
-               string "this" $> SThis,
-               string "that" $> SThat,
-               string "constant" $> SConstant,
-               string "static" $> SStatic,
-               string "pointer" $> SPointer,
-               string "temp" $> STemp
-             ] <* space1
-
-    parseSegmentOffset :: Parser SegmentOffset
-    parseSegmentOffset = SegmentOffset <$> L.decimal
+    parseSegment :: Parser Segment
+    parseSegment =
+      choice [ parseSegmentInt "local" SLocal,
+               parseSegmentInt "argument"  SArgument,
+               parseSegmentInt "this"  SThis,
+               parseSegmentInt "that"  SThat,
+               parseSegmentInt "constant" SConstant,
+               (string "static" *> space1) *> (SStatic <$> parseId),
+               parseSegmentInt "pointer" SPointer,
+               parseSegmentInt "temp" STemp
+             ]
+
+
+    parseId :: Parser T.Text
+    parseId = do
+      h <- letterChar
+      hs <- many (alphaNumChar <|> char '.' <|> char '_')
+      return $ T.pack (h : hs)
+
+
+    parseSegmentInt :: T.Text -> (Int -> Segment) -> Parser Segment
+    parseSegmentInt sname f = try $ do
+      string sname
+      space1
+      f <$> L.decimal
 
     parseArithmetic :: Parser VMInstruction
     parseArithmetic = VMArithmetic <$>
@@ -98,3 +131,65 @@ parseInstruction =
                string "or" $> ACOr,
                string "not" $> ACNot
              ]
+
+data AnnotatedAsmLine =
+    Comment T.Text
+  | Code HackInstruction
+  deriving (Show, Eq)
+
+compileInstruction :: VMInstruction -> [AnnotatedAsmLine]
+compileInstruction instr =
+  Comment (instrAnnotation instr) : compileInstruction' instr
+
+  where
+    compileInstruction' (VMMemAccess ACPush segment) =
+      case segment of
+        SLocal offset -> pushSeq "LCL" offset
+        SArgument offset -> pushSeq "ARG" offset
+        SThis offset -> pushSeq "THIS" offset
+        SThat offset -> pushSeq "THAT" offset
+        SConstant offset -> [
+          Code (A . Imm $ offset),
+          Code (C [RegD] (SReg RegA) JNone),
+          Code (A (Label "SP")),
+          Code (C [RegA] (SReg RegM) JNone),
+          Code (C [RegM] (SReg RegD) JNone),
+          Code (C [RegD] (SRegPlus1 RegA) JNone),
+          Code (A (Label "SP")),
+          Code (C [RegM] (SReg RegD) JNone) ]
+        SStatic label -> pushLabelValue label
+        SPointer offset -> if offset == 0 then pushLabelValue "THIS" else pushLabelValue "THAT"
+        STemp offset -> [
+          Code (A . Imm $ (5 + offset)),
+          Code (C [RegD] (SReg RegM) JNone),
+          Code (A (Label "SP")),
+          Code (C [RegA] (SReg RegM) JNone),
+          Code (C [RegM] (SReg RegD) JNone),
+          Code (C [RegD] (SRegPlus1 RegA) JNone),
+          Code (A (Label "SP")),
+          Code (C [RegM] (SReg RegD) JNone) ]
+
+
+    pushLabelValue label = [
+          Code (A . Label $ label),
+          Code (C [RegD] (SReg RegM) JNone),
+          Code (A (Label "SP")),
+          Code (C [RegA] (SReg RegM) JNone),
+          Code (C [RegM] (SReg RegD) JNone),
+          Code (C [RegD] (SRegPlus1 RegA) JNone),
+          Code (A (Label "SP")),
+          Code (C [RegM] (SReg RegD) JNone) ]
+
+    pushSeq regName offset = [
+          Code (A . Imm $ offset),
+          Code (C [RegD] (SReg RegA) JNone),
+          Code (A (Label regName)),
+          Code (C [RegA] (SReg RegM) JNone),
+          Code (C [RegA] SDPlusA JNone),
+          Code (C [RegD] (SReg RegM) JNone),
+          Code (A (Label "SP")),
+          Code (C [RegA] (SReg RegM) JNone),
+          Code (C [RegM] (SReg RegD) JNone),
+          Code (C [RegD] (SRegPlus1 RegA) JNone),
+          Code (A (Label "SP")),
+          Code (C [RegM] (SReg RegD) JNone) ]

test/Test/Nand2Tetris/VM.hs

@@ -5,48 +5,55 @@ module Test.Nand2Tetris.VM
     spec
   ) where
 
-import Test.Hspec (Spec, describe, it, shouldBe)
+import           Test.Hspec       (Spec, describe, it, shouldBe)
+
+import           Nand2Tetris.Hack (HackInstruction (..), Imm (..), Jump (..),
+                                   Reg (..), Source (..))
+import           Nand2Tetris.VM   (AccessType (ACPop, ACPush),
+                                   AnnotatedAsmLine (..),
+                                   ArithmeticCmd (ACAdd, ACAnd, ACEq, ACGt, ACLt, ACNeg, ACNot, ACOr, ACSub),
+                                   Segment (SArgument, SConstant, SLocal, SPointer, SStatic, STemp, SThat, SThis),
+                                   VMInstruction (VMArithmetic, VMMemAccess),
+                                   compileInstruction, parseInstruction)
+import           Text.Megaparsec  (runParser)
 
-import Nand2Tetris.VM (VMInstruction(VMMemAccess, VMArithmetic),
-                       SegmentOffset(SegmentOffset),
-                       AccessType(ACPush, ACPop),
-                       SegmentId(SArgument, SLocal, SThis, SThat, SConstant, STemp, SPointer, SStatic),
-                       SegmentOffset(SegmentOffset),
-                       parseInstruction, ArithmeticCmd (ACAdd, ACNeg, ACSub, ACEq, ACGt, ACLt, ACAnd, ACOr, ACNot))
-import Text.Megaparsec (runParser)
 
 spec :: Spec
 spec = do
-  describe "parseInstruction" $ do
+  describe "parseInstruction" parseInstructionSpec
+  describe "compileInstruction" compileInstructionSpec
+
+parseInstructionSpec :: Spec
+parseInstructionSpec = do
     it "Parses instruction: push argument 42" $
-      doParse "push argument 42" `shouldBe` Right (VMMemAccess ACPush SArgument (SegmentOffset 42))
+      doParse "push argument 42" `shouldBe` Right (VMMemAccess ACPush (SArgument 42))
 
     it "Parses instruction: pop argument 42" $
-      doParse "pop argument 42" `shouldBe` Right (VMMemAccess ACPop SArgument (SegmentOffset 42))
+      doParse "pop argument 42" `shouldBe` Right (VMMemAccess ACPop (SArgument 42))
 
     it "Parses instruction: push local 42" $
-      doParse "push local 42" `shouldBe` Right (VMMemAccess ACPush SLocal (SegmentOffset 42))
+      doParse "push local 42" `shouldBe` Right (VMMemAccess ACPush (SLocal 42))
 
     it "Parses instruction: push this 42" $
-      doParse "push this 42" `shouldBe` Right (VMMemAccess ACPush SThis (SegmentOffset 42))
+      doParse "push this 42" `shouldBe` Right (VMMemAccess ACPush (SThis 42))
 
     it "Parses instruction: push that 42" $
-      doParse "push that 42" `shouldBe` Right (VMMemAccess ACPush SThat (SegmentOffset 42))
+      doParse "push that 42" `shouldBe` Right (VMMemAccess ACPush (SThat 42))
 
     it "Parses instruction: push constant 42" $
-      doParse "push constant 42" `shouldBe` Right (VMMemAccess ACPush SConstant (SegmentOffset 42))
+      doParse "push constant 42" `shouldBe` Right (VMMemAccess ACPush (SConstant 42))
 
-    it "Parses instruction: push static 42" $
-      doParse "push static 42" `shouldBe` Right (VMMemAccess ACPush SStatic (SegmentOffset 42))
+    it "Parses instruction: push static Foo.1" $
+      doParse "push static Foo.1" `shouldBe` Right (VMMemAccess ACPush (SStatic "Foo.1"))
 
     it "Parses instruction: push pointer 42" $
-      doParse "push pointer 42" `shouldBe` Right (VMMemAccess ACPush SPointer (SegmentOffset 42))
+      doParse "push pointer 42" `shouldBe` Right (VMMemAccess ACPush (SPointer 42))
 
     it "Parses instruction: push temp 42" $
-      doParse "push temp 42" `shouldBe` Right (VMMemAccess ACPush STemp (SegmentOffset 42))
+      doParse "push temp 42" `shouldBe` Right (VMMemAccess ACPush (STemp 42))
 
     it "Parses instruction: push temp 11" $
-      doParse "push temp 11" `shouldBe` Right (VMMemAccess ACPush STemp (SegmentOffset 11))
+      doParse "push temp 11" `shouldBe` Right (VMMemAccess ACPush (STemp 11))
 
     it "Parses instruction: add" $
       doParse "add" `shouldBe` Right (VMArithmetic ACAdd)
@@ -77,3 +84,91 @@ spec = do
 
   where
     doParse = runParser parseInstruction ""
+
+compileInstructionSpec :: Spec
+compileInstructionSpec = do
+  it "Compiles push argument 42" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (SArgument 42))
+    head compiled `shouldBe` (Comment "push argument 42")
+    tail compiled `shouldBe` pushValue "ARG" 42
+
+  it "Compiles push local 42" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (SLocal 42))
+    head compiled `shouldBe` (Comment "push local 42")
+    tail compiled `shouldBe` pushValue "LCL" 42
+
+  it "Compiles push this 41" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (SThis 41))
+    head compiled `shouldBe` (Comment "push this 41")
+    tail compiled `shouldBe` pushValue "THIS" 41
+
+  it "Compiles push that 41" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (SThat 41))
+    head compiled `shouldBe` (Comment "push that 41")
+    tail compiled `shouldBe` pushValue "THAT" 41
+
+  it "Compiles push constant 17" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (SConstant 17))
+    head compiled `shouldBe` (Comment "push constant 17")
+    tail compiled `shouldBe` [
+        Code (A (Imm 17)),
+        Code (C [RegD] (SReg RegA) JNone),
+        Code (A (Label "SP")),
+        Code (C [RegA] (SReg RegM) JNone),
+        Code (C [RegM] (SReg RegD) JNone),
+        Code (C [RegD] (SRegPlus1 RegA) JNone),
+        Code (A (Label "SP")),
+        Code (C [RegM] (SReg RegD) JNone) ]
+
+  it "Compiles push static Foo.1" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (SStatic "Foo.1"))
+    head compiled `shouldBe` (Comment "push static Foo.1")
+    tail compiled `shouldBe` pushLabel "Foo.1"
+
+  it "Compiles push pointer 0" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (SPointer 0))
+    head compiled `shouldBe` (Comment "push pointer 0")
+    tail compiled `shouldBe` pushLabel "THIS"
+
+  it "Compiles push pointer 1" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (SPointer 1))
+    head compiled `shouldBe` (Comment "push pointer 1")
+    tail compiled `shouldBe` pushLabel "THAT"
+
+  it "Compiles push temp 2" $ do
+    let compiled = compileInstruction (VMMemAccess ACPush (STemp 2))
+    head compiled `shouldBe` (Comment "push temp 2")
+    tail compiled `shouldBe` pushRam (5 + 2)
+
+    where
+      pushRam offset = [ Code (A (Imm offset)),
+                          Code (C [RegD] (SReg RegM) JNone),
+                          Code (A (Label "SP")),
+                          Code (C [RegA] (SReg RegM) JNone),
+                          Code (C [RegM] (SReg RegD) JNone),
+                          Code (C [RegD] (SRegPlus1 RegA) JNone),
+                          Code (A (Label "SP")),
+                          Code (C [RegM] (SReg RegD) JNone) ]
+      pushLabel label = [ Code (A (Label label)),
+                          Code (C [RegD] (SReg RegM) JNone),
+                          Code (A (Label "SP")),
+                          Code (C [RegA] (SReg RegM) JNone),
+                          Code (C [RegM] (SReg RegD) JNone),
+                          Code (C [RegD] (SRegPlus1 RegA) JNone),
+                          Code (A (Label "SP")),
+                          Code (C [RegM] (SReg RegD) JNone) ]
+
+      pushValue reg value = [ Code (A (Imm value)),
+                              Code (C [RegD] (SReg RegA) JNone),
+                              Code (A (Label reg)),
+                              Code (C [RegA] (SReg RegM) JNone),
+                              Code (C [RegA] SDPlusA JNone),
+                              Code (C [RegD] (SReg RegM) JNone),
+                              Code (A (Label "SP")),
+                              Code (C [RegA] (SReg RegM) JNone),
+                              Code (C [RegM] (SReg RegD) JNone),
+                              Code (C [RegD] (SRegPlus1 RegA) JNone),
+                              Code (A (Label "SP")),
+                              Code (C [RegM] (SReg RegD) JNone) ]
+
+