diff --git a/nand2tetris.cabal b/nand2tetris.cabal index 9863d7d..af6ccf7 100644 --- a/nand2tetris.cabal +++ b/nand2tetris.cabal @@ -29,10 +29,21 @@ library hs-source-dirs: src default-language: Haskell2010 exposed-modules: Nand2Tetris.Hack + , Nand2Tetris.VM , Nand2Tetris.Error build-depends: base >= 4.7 && < 5 , text , megaparsec , containers - \ No newline at end of file +test-suite nand2tetris-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + main-is: Spec.hs + other-modules: Test.Nand2Tetris.VM + build-depends: base >= 4.7 && < 5 + , nand2tetris + , hspec + , megaparsec + diff --git a/src/Nand2Tetris/VM.hs b/src/Nand2Tetris/VM.hs new file mode 100644 index 0000000..e6735a9 --- /dev/null +++ b/src/Nand2Tetris/VM.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Nand2Tetris.VM + ( + VMInstruction(..), + ArithmeticCmd(..), + AccessType(..), + SegmentOffset(..), + SegmentId(..), + parseInstruction + ) where + +import Nand2Tetris.Error ( Error ) +import Text.Megaparsec (Parsec, MonadParsec (try), (<|>), choice) +import qualified Data.Text as T +import Text.Megaparsec.Char (string, space1) +import Data.Functor (($>)) +import qualified Text.Megaparsec.Char.Lexer as L + +data VMInstruction = + VMArithmetic ArithmeticCmd + | VMMemAccess AccessType SegmentId SegmentOffset + deriving (Show, Eq) + +data ArithmeticCmd = + ACAdd + | ACSub + | ACNeg + | ACEq + | ACGt + | ACLt + | ACAnd + | ACOr + | ACNot + deriving (Show, Eq) + +data AccessType = + ACPush + | ACPop + deriving (Show, Eq) + +newtype SegmentOffset = SegmentOffset { unSegmentOffset :: Int } + deriving (Show, Eq) + +data SegmentId = + SLocal + | SArgument + | SThis + | SThat + | SConstant + | SStatic + | SPointer + | STemp + deriving (Show, Eq) + +type Parser = Parsec Error T.Text + +parseInstruction :: Parser VMInstruction +parseInstruction = + try parseMemAccess <|> + parseArithmetic + + where + parseMemAccess :: Parser VMInstruction + parseMemAccess = VMMemAccess <$> + parseAccessType <*> + parseSegmentId <*> + parseSegmentOffset + + 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 + + parseArithmetic :: Parser VMInstruction + parseArithmetic = VMArithmetic <$> + choice [ string "add" $> ACAdd, + string "sub" $> ACSub, + string "neg" $> ACNeg, + string "eq" $> ACEq, + string "gt" $> ACGt, + string "lt" $> ACLt, + string "and" $> ACAnd, + string "or" $> ACOr, + string "not" $> ACNot + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..ab4b74f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,13 @@ + +module Main (main) where +import Test.Hspec (hspec, Spec, describe) + +import qualified Test.Nand2Tetris.VM as VM + +main = hspec spec + +spec :: Spec +spec = do + describe "VM" VM.spec + + diff --git a/test/Test/Nand2Tetris/VM.hs b/test/Test/Nand2Tetris/VM.hs new file mode 100644 index 0000000..1df0183 --- /dev/null +++ b/test/Test/Nand2Tetris/VM.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Nand2Tetris.VM + ( + spec + ) where + +import Test.Hspec (Spec, describe, it, shouldBe) + +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 + it "Parses instruction: push argument 42" $ + doParse "push argument 42" `shouldBe` Right (VMMemAccess ACPush SArgument (SegmentOffset 42)) + + it "Parses instruction: pop argument 42" $ + doParse "pop argument 42" `shouldBe` Right (VMMemAccess ACPop SArgument (SegmentOffset 42)) + + it "Parses instruction: push local 42" $ + doParse "push local 42" `shouldBe` Right (VMMemAccess ACPush SLocal (SegmentOffset 42)) + + it "Parses instruction: push this 42" $ + doParse "push this 42" `shouldBe` Right (VMMemAccess ACPush SThis (SegmentOffset 42)) + + it "Parses instruction: push that 42" $ + doParse "push that 42" `shouldBe` Right (VMMemAccess ACPush SThat (SegmentOffset 42)) + + it "Parses instruction: push constant 42" $ + doParse "push constant 42" `shouldBe` Right (VMMemAccess ACPush SConstant (SegmentOffset 42)) + + it "Parses instruction: push static 42" $ + doParse "push static 42" `shouldBe` Right (VMMemAccess ACPush SStatic (SegmentOffset 42)) + + it "Parses instruction: push pointer 42" $ + doParse "push pointer 42" `shouldBe` Right (VMMemAccess ACPush SPointer (SegmentOffset 42)) + + it "Parses instruction: push temp 42" $ + doParse "push temp 42" `shouldBe` Right (VMMemAccess ACPush STemp (SegmentOffset 42)) + + it "Parses instruction: push temp 11" $ + doParse "push temp 11" `shouldBe` Right (VMMemAccess ACPush STemp (SegmentOffset 11)) + + it "Parses instruction: add" $ + doParse "add" `shouldBe` Right (VMArithmetic ACAdd) + + it "Parses instruction: sub" $ + doParse "sub" `shouldBe` Right (VMArithmetic ACSub) + + it "Parses instruction: neg" $ + doParse "neg" `shouldBe` Right (VMArithmetic ACNeg) + + it "Parses instruction: eq" $ + doParse "eq" `shouldBe` Right (VMArithmetic ACEq) + + it "Parses instruction: gt" $ + doParse "gt" `shouldBe` Right (VMArithmetic ACGt) + + it "Parses instruction: lt" $ + doParse "lt" `shouldBe` Right (VMArithmetic ACLt) + + it "Parses instruction: and" $ + doParse "and" `shouldBe` Right (VMArithmetic ACAnd) + + it "Parses instruction: or" $ + doParse "or" `shouldBe` Right (VMArithmetic ACOr) + + it "Parses instruction: not" $ + doParse "not" `shouldBe` Right (VMArithmetic ACNot) + + where + doParse = runParser parseInstruction ""