diff --git a/app/HackAsm.hs b/app/HackAsm.hs new file mode 100644 index 0000000..f43557e --- /dev/null +++ b/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" ) diff --git a/hackasm.cabal b/hackasm.cabal deleted file mode 100644 index 16f5e8f..0000000 --- a/hackasm.cabal +++ /dev/null @@ -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 diff --git a/nand2tetris.cabal b/nand2tetris.cabal new file mode 100644 index 0000000..10261eb --- /dev/null +++ b/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 + + \ No newline at end of file diff --git a/src/Main.hs b/src/Nand2Tetris/Hack.hs similarity index 53% rename from src/Main.hs rename to src/Nand2Tetris/Hack.hs index b130162..09a7557 100644 --- a/src/Main.hs +++ b/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