VM instructions parser

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
 
+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
 

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
+             ]

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
+
+

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 ""