nand2tetris/src/Nand2Tetris/VM.hs

{-# 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
             ]