Refactoring

Hack assembler definitions are now in separate module.
This will be handy when I implement VM compiler

app/HackAsm.hs

@@ -0,0 +1,62 @@
+
+module Main (main) where
+
+import           Control.Monad         (forM_)
+import           Data.Bits             (testBit)
+import           Data.Foldable         (foldl', foldr)
+import qualified Data.Map.Strict       as M
+import qualified Data.Text             as T
+import qualified Data.Text.IO          as TIO
+import           Nand2Tetris.Hack      (AsmLine (LineInstruction), addLabels,
+                                        addVars, compile, defaultVars,
+                                        hackParser)
+import           Options.Applicative   (execParser, fullDesc, header, help,
+                                        helper, info, long, metavar, progDesc,
+                                        short, strOption, (<**>))
+import           System.IO             (IOMode (WriteMode), hPutStrLn, withFile)
+import           Text.Megaparsec       (runParser)
+import           Text.Megaparsec.Error (ParseErrorBundle,
+                                        ShowErrorComponent (showErrorComponent),
+                                        errorBundlePretty)
+
+data Options =
+  Options
+  {
+    inputFile  :: FilePath,
+    outputFile :: FilePath
+  }
+
+main :: IO ()
+main = do
+  options <- execParser opts
+  programText <- TIO.readFile (inputFile options)
+  let result = runParser hackParser (inputFile options) programText
+  case result of
+    Left err -> putStrLn $ errorBundlePretty err
+    Right parsed -> do
+      let labels = addLabels M.empty parsed
+      let vars = addVars defaultVars labels parsed
+      print vars
+      let compiled = compile labels vars $ foldr addInstr [] parsed
+      case compiled of
+        Left err -> putStrLn $ "Error: " <> T.unpack err
+        Right program -> withFile (outputFile options) WriteMode $ \h -> forM_ program (\x -> hPutStrLn h (printInstruction x))
+  where
+    printInstruction w = concatMap (\x -> if testBit w x then "1" else "0") $ reverse [0..15]
+    regVars = defaultVars
+    addInstr (LineInstruction instr) is = instr : is
+    addInstr _ is                       = is
+
+    opts = info (hackAsmOptParser <**> helper)
+             ( fullDesc
+            <> progDesc "Compiles a file with Hack assembly instructions to Hask binary code"
+            <> header "hackasm - assembler for hack CPU (nand2tetris)" )
+    hackAsmOptParser = Options <$>
+      strOption ( long "input"
+               <> short 'i'
+               <> metavar "FILENAME"
+               <> help "Input file" ) <*>
+      strOption ( long "output"
+               <> short 'o'
+               <> metavar "FILENAME"
+               <> help "Output file" )

hackasm.cabal

@@ -1,26 +0,0 @@
-name:                hackasm
-version:             0.1.0.0
--- synopsis:
--- description:
-homepage:            https://github.com/githubuser/hackasm#readme
-license:             BSD3
-license-file:        LICENSE
-author:              Author name here
-maintainer:          example@example.com
-copyright:           2021 Author name here
-category:            Web
-build-type:          Simple
-cabal-version:       >=1.10
-extra-source-files:  README.md
-
-executable hackasm
-  hs-source-dirs:      src
-  main-is:             Main.hs
-  default-language:    Haskell2010
-  build-depends:       base >= 4.7 && < 5
-                     , text
-                     , megaparsec
-                     , optparse-applicative
-                     , containers
-                     , bytestring
-                     , binary

nand2tetris.cabal

@@ -0,0 +1,37 @@
+name:                nand2tetris
+version:             0.1.0.0
+-- synopsis:
+-- description:
+homepage:            https://c.asakul.ru/asakul/nand2tetris
+license:             BSD3
+license-file:        LICENSE
+author:              Denis Tereshkin
+maintainer:          denis@kasan.ws
+copyright:           2021 Denis Tereshkin
+category:            Web
+build-type:          Simple
+cabal-version:       >=1.10
+extra-source-files:  README.md
+
+executable hackasm
+  hs-source-dirs:      app
+  main-is:             HackAsm.hs
+  default-language:    Haskell2010
+  build-depends:       base >= 4.7 && < 5
+                     , nand2tetris
+                     , text
+                     , megaparsec
+                     , optparse-applicative
+                     , containers
+                     , bytestring
+
+library
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  exposed-modules:     Nand2Tetris.Hack
+  build-depends:       base >= 4.7 && < 5
+                     , text
+                     , megaparsec
+                     , containers
+
+                       

src/Nand2Tetris/Hack.hs

@@ -1,32 +1,44 @@
+{-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiWayIf #-}
-
-module Main where
-
-import Data.Binary
-import qualified Data.Map.Strict as M
-import qualified Data.Text as T
-import qualified Data.Text.IO as TIO
-import qualified Data.ByteString.Lazy as BL
-import Text.Megaparsec (Parsec, runParserT, many, skipManyTill, runParser, some, errorBundlePretty, ShowErrorComponent, skipMany, notFollowedBy, MonadParsec (eof, lookAhead), choice, try, oneOf)
-import qualified Options.Applicative as O
-import Options.Applicative (fullDesc, info, (<**>), helper, progDesc, header, strOption, long, metavar, help, execParser, short)
-import Control.Applicative hiding (many, some)
-import Text.Megaparsec.Char (char, space, eol, alphaNumChar, letterChar, string, printChar, spaceChar, space1, string')
-import Text.Megaparsec.Error (ShowErrorComponent(showErrorComponent))
-import Text.Megaparsec.Debug
-import Control.Monad (void, when, forM, forM_)
-import Text.Megaparsec.Char.Lexer (decimal, skipLineComment, symbol)
+
+module Nand2Tetris.Hack
+  (
+    HackInstruction(..),
+    Imm(..),
+    Reg(..),
+    Source(..),
+    Jump(..),
+    AsmLine(..),
+    hackParser,
+    defaultVars,
+    compile,
+    LabelMap,
+    Error(..),
+    addVars,
+    addLabels
+  ) where
+
+import           Control.Monad              (forM, when)
+import           Data.Bits                  (Bits (shift), (.|.))
+import           Data.Foldable              (Foldable (foldl'))
+import           Data.Functor               (($>))
+import qualified Data.Map.Strict            as M
+import           Data.Maybe                 (fromMaybe)
+import qualified Data.Text                  as T
+import           Data.Word                  (Word16)
+import           Text.Megaparsec            (MonadParsec (try), Parsec,
+                                             ShowErrorComponent, choice, empty,
+                                             eof, many, oneOf, optional,
+                                             skipManyTill, some, (<|>))
+import           Text.Megaparsec.Char       (alphaNumChar, char, letterChar,
+                                             space, space1, string, string')
+import           Text.Megaparsec.Char.Lexer (decimal, skipLineComment)
 import qualified Text.Megaparsec.Char.Lexer as L
-import Data.Maybe (catMaybes, fromMaybe)
-import Text.Megaparsec.Byte.Lexer (symbol')
-import Data.Foldable (Foldable(foldl'))
-import Data.Word (Word16)
-import Data.Bits ((.|.), Bits (shift, testBit))
-import Debug.Trace
-import GHC.IO.IOMode (IOMode(WriteMode))
-import System.IO (withFile, hPutStrLn)
+import Text.Megaparsec.Error (ShowErrorComponent(showErrorComponent))
 
+defaultVars :: LabelMap
+defaultVars = M.fromList $ [("SP", 0), ("LCL", 1), ("ARG", 2), ("THIS", 3), ("THAT", 4)] <>
+      zip (fmap (\x -> "R" <> (T.pack . show $ x)) [0..15 :: Int]) [0..15 :: Int]
 
 data HackInstruction =
     A Imm
@@ -76,7 +88,6 @@ data Error = ParsingError T.Text Int
 
 instance ShowErrorComponent Error where
   showErrorComponent = show
-
 type Parser = Parsec Error T.Text
 
 data AsmLine =
@@ -84,13 +95,6 @@ data AsmLine =
   | LineLabel T.Text
   deriving (Show, Eq)
 
-data Options =
-  Options
-  {
-    inputFile :: FilePath,
-    outputFile :: FilePath
-  }
-
 hackParser :: Parser [AsmLine]
 hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
   where
@@ -117,13 +121,13 @@ hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
       return . LineInstruction $ C (fromMaybe [] target) comp (fromMaybe JNone jump)
 
     parseReg :: Parser Reg
-    parseReg = try (char 'A' *> pure RegA) <|> try (char 'D' *> pure RegD) <|> try (char 'M' *> pure RegM)
+    parseReg = try (char 'A' $> RegA) <|> try (char 'D' $> RegD) <|> try (char 'M' $> RegM)
 
     parseComputation :: Parser Source
     parseComputation = space >>
-      (try $ char '0' *> pure S0) <|>
-      (try $ char '1' *> pure S1) <|>
-      (try $ string "-1" *> pure SNeg1) <|>
+      (try $ char '0' $> S0) <|>
+      (try $ char '1' $> S1) <|>
+      (try $ string "-1" $> SNeg1) <|>
       (try $ char '!' *> space *> parseReg >>= pure . SNot) <|>
       (try $ char '-' *> space *> parseReg >>= pure . SNeg) <|>
       (try $ parseReg <* space <* char '+' <* space <* char '1' >>= pure . SRegPlus1) <|>
@@ -147,10 +151,11 @@ hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
         | op == '&' ->
           return $ if r1 == RegA || r2 == RegA then SDAndA else SDAndM
         | op == '|' ->
-          return $ if r1 == RegA || r2 == RegA then SDOrM else SDOrM
+          return $ if r1 == RegA || r2 == RegA then SDOrA else SDOrM
         | op == '-' && r1 == RegD -> return $ if r2 == RegA then SDMinusA else SDMinusM
         | op == '-' && r1 == RegA -> return SAMinusD
         | op == '-' && r1 == RegM -> return SMMinusD
+        | otherwise -> fail "Invalid operands"
 
     parseJump :: Parser Jump
     parseJump = try $ do
@@ -175,25 +180,28 @@ hackParser = many (sp *> choice [parseInstruction, parseLabel] <* sp) <* eof
     idParser :: Parser T.Text
     idParser = T.pack <$> some (letterChar <|> oneOf ['.', '_', '$']) <> many alphaNumChar
 
-    notEol :: Parser Char
-    notEol = skipManyTill (notFollowedBy eol) spaceChar
-
     sp :: Parser ()
     sp = L.space space1 (skipLineComment "//") empty
 
 type LabelMap = M.Map T.Text Int
 
+addLabels :: LabelMap -> [AsmLine] -> LabelMap
+addLabels m parsed = snd $ foldl' addLabel (0, m) parsed
+
+addVars :: LabelMap -> LabelMap -> [AsmLine] -> LabelMap
+addVars m labels parsed = snd $ foldl' (addVar labels) (16, m) parsed
+
 addLabel :: (Int, LabelMap) -> AsmLine -> (Int, LabelMap)
 addLabel (i, m) (LineInstruction _) = (i + 1, m)
-addLabel (i, m) (LineLabel v) = (i, M.insert v i m)
+addLabel (i, m) (LineLabel v)       = (i, M.insert v i m)
 
-addVars :: LabelMap -> (Int, LabelMap) -> AsmLine -> (Int, LabelMap)
-addVars labs (cnt, m) (LineInstruction (A (Label v))) = case M.lookup v labs of
+addVar :: LabelMap -> (Int, LabelMap) -> AsmLine -> (Int, LabelMap)
+addVar labs (cnt, m) (LineInstruction (A (Label v))) = case M.lookup v labs of
   Just _ -> (cnt, m)
   Nothing -> case M.lookup v m of
-    Just _-> (cnt, m)
+    Just _  -> (cnt, m)
     Nothing -> (cnt + 1, M.insert v cnt m)
-addVars _ m _ = m
+addVar _ m _ = m
 
 compile :: LabelMap -> LabelMap -> [HackInstruction] -> Either T.Text [Word16]
 compile labels vars lines = forM lines compileInstruction
@@ -207,41 +215,41 @@ compile labels vars lines = forM lines compileInstruction
         Just offset -> Right $ fromIntegral offset
         Nothing -> case M.lookup l vars of
           Just offset -> Right $ fromIntegral offset
-          Nothing -> Left $ "Invalid label: " <> l
+          Nothing     -> Left $ "Invalid label: " <> l
     compileInstruction (C dest src jmp) = Right $
       0xe000 .|. compileSourceOperand src  .|. compileDestOperand dest .|. compileJump jmp
 
     compileSourceOperand :: Source -> Word16
     compileSourceOperand src = compileSourceOperand' src `shift` 6
 
-    compileSourceOperand' S0 = 0x2a
-    compileSourceOperand' S1 = 0x3f
-    compileSourceOperand' SNeg1 = 0x3a
-    compileSourceOperand' (SReg RegA) = 0x30
-    compileSourceOperand' (SReg RegM) = 0x70
-    compileSourceOperand' (SReg RegD) = 0x0c
-    compileSourceOperand' (SNot RegA) = 0x31
-    compileSourceOperand' (SNot RegM) = 0x71
-    compileSourceOperand' (SNot RegD) = 0x0d
-    compileSourceOperand' (SNeg RegA) = 0x33
-    compileSourceOperand' (SNeg RegM) = 0x73
-    compileSourceOperand' (SNeg RegD) = 0x0f
-    compileSourceOperand' (SRegPlus1 RegA) = 0x37
-    compileSourceOperand' (SRegPlus1 RegM) = 0x77
-    compileSourceOperand' (SRegPlus1 RegD) = 0x1f
+    compileSourceOperand' S0                = 0x2a
+    compileSourceOperand' S1                = 0x3f
+    compileSourceOperand' SNeg1             = 0x3a
+    compileSourceOperand' (SReg RegA)       = 0x30
+    compileSourceOperand' (SReg RegM)       = 0x70
+    compileSourceOperand' (SReg RegD)       = 0x0c
+    compileSourceOperand' (SNot RegA)       = 0x31
+    compileSourceOperand' (SNot RegM)       = 0x71
+    compileSourceOperand' (SNot RegD)       = 0x0d
+    compileSourceOperand' (SNeg RegA)       = 0x33
+    compileSourceOperand' (SNeg RegM)       = 0x73
+    compileSourceOperand' (SNeg RegD)       = 0x0f
+    compileSourceOperand' (SRegPlus1 RegA)  = 0x37
+    compileSourceOperand' (SRegPlus1 RegM)  = 0x77
+    compileSourceOperand' (SRegPlus1 RegD)  = 0x1f
     compileSourceOperand' (SRegMinus1 RegA) = 0x32
     compileSourceOperand' (SRegMinus1 RegM) = 0x72
     compileSourceOperand' (SRegMinus1 RegD) = 0x0e
-    compileSourceOperand' SDPlusA = 0x02
-    compileSourceOperand' SDPlusM = 0x42
-    compileSourceOperand' SDMinusA = 0x13
-    compileSourceOperand' SDMinusM = 0x53
-    compileSourceOperand' SAMinusD = 0x07
-    compileSourceOperand' SMMinusD = 0x47
-    compileSourceOperand' SDAndA = 0x00
-    compileSourceOperand' SDAndM = 0x40
-    compileSourceOperand' SDOrA = 0x15
-    compileSourceOperand' SDOrM = 0x55
+    compileSourceOperand' SDPlusA           = 0x02
+    compileSourceOperand' SDPlusM           = 0x42
+    compileSourceOperand' SDMinusA          = 0x13
+    compileSourceOperand' SDMinusM          = 0x53
+    compileSourceOperand' SAMinusD          = 0x07
+    compileSourceOperand' SMMinusD          = 0x47
+    compileSourceOperand' SDAndA            = 0x00
+    compileSourceOperand' SDAndM            = 0x40
+    compileSourceOperand' SDOrA             = 0x15
+    compileSourceOperand' SDOrM             = 0x55
 
     compileDestOperand dests = compileDestOperand' dests `shift` 3
     compileDestOperand' :: [Reg] -> Word16
@@ -253,49 +261,10 @@ compile labels vars lines = forM lines compileInstruction
     compileDestBit b RegD = b .|. 2
 
     compileJump JNone = 0
-    compileJump JGt = 1
-    compileJump JEq = 2
-    compileJump JGe = 3
-    compileJump JLt = 4
-    compileJump JNe = 5
-    compileJump JLe = 6
-    compileJump Jmp = 7
-
-
-main :: IO ()
-main = do
-  options <- execParser opts
-  programText <- TIO.readFile (inputFile options)
-  let result = runParser hackParser (inputFile options) programText
-  case result of
-    Left err -> putStrLn $ errorBundlePretty err
-    Right parsed -> do
-      let labels = snd $ foldl' addLabel (0, M.empty) parsed
-      let vars = snd $ foldl' (addVars labels) (16, regVars) parsed
-      print vars
-      let compiled = compile labels vars $ foldr addInstr [] parsed
-      case compiled of
-        Left err -> putStrLn $ "Error: " <> T.unpack err
-        Right program -> withFile (outputFile options) WriteMode $ \h -> forM_ program (\x -> hPutStrLn h (printInstruction x))
-  where
-    printInstruction w = concatMap (\x -> if testBit w x then "1" else "0") $ reverse [0..15]
-    regVars = M.fromList $ [("SP", 0), ("LCL", 1), ("ARG", 2), ("THIS", 3), ("THAT", 4)] <>
-      zip (fmap (\x -> "R" <> (T.pack . show $ x)) [0..15 :: Int]) [0..15 :: Int]
-    addInstr (LineInstruction instr) is = instr : is
-    addInstr _ is = is
-
-    opts = info (hackAsmOptParser <**> helper)
-             ( fullDesc
-            <> progDesc "Compiles a file with Hack assembly instructions to Hask binary code"
-            <> header "hackasm - assembler for hack CPU (nand2tetris)" )
-    hackAsmOptParser = Options <$>
-      strOption ( long "input"
-               <> short 'i'
-               <> metavar "FILENAME"
-               <> help "Input file" ) <*>
-      strOption ( long "output"
-               <> short 'o'
-               <> metavar "FILENAME"
-               <> help "Output file" )
-
-
+    compileJump JGt   = 1
+    compileJump JEq   = 2
+    compileJump JGe   = 3
+    compileJump JLt   = 4
+    compileJump JNe   = 5
+    compileJump JLe   = 6
+    compileJump Jmp   = 7