diff --git a/src/Nand2Tetris/VM.hs b/src/Nand2Tetris/VM.hs index e6735a9..7d1b95a 100644 --- a/src/Nand2Tetris/VM.hs +++ b/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) ] diff --git a/test/Test/Nand2Tetris/VM.hs b/test/Test/Nand2Tetris/VM.hs index 1df0183..d550723 100644 --- a/test/Test/Nand2Tetris/VM.hs +++ b/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) ] + +