Squash merge golden-tests into main

Add golden tests and commit assembly examples

app/Main.hs

@@ -6,17 +6,13 @@ import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Parser qualified
-import Path
+import Text.Megaparsec.Error (errorBundlePretty)
 
 main :: IO ()
 main = do
   (Options sourceCodePath) <- runCmdOptions
   putStrLn $ "FILEPATH: " <> sourceCodePath
   assemblyCode <- T.readFile sourceCodePath
-  -- T.putStrLn assemblyCode
-  -- T.putStrLn $ T.replicate 10 "-"
-  mayStatements <- Parser.mainLocal assemblyCode
-  case mayStatements of
-    Nothing -> T.putStrLn "No results to be written"
-    Just statements -> do
-      writeBin sourceCodePath statements
+  case Parser.parseAssembly sourceCodePath assemblyCode of
+    Left e -> putStrLn $ errorBundlePretty e
+    Right statements -> writeBin sourceCodePath statements

asmh.cabal

@@ -33,7 +33,6 @@ common common-options
     -funbox-strict-fields
     -fexpose-all-unfoldings
     -threaded
-    -with-rtsopts=-N
     -Wunused-packages
 
   default-extensions:
@@ -64,12 +63,16 @@ library
     megaparsec,
     path,
     text,
+    text-display,
     vector,
 
 executable asmh
   import:
     common-options
 
+  ghc-options:
+    -with-rtsopts=-N
+
   hs-source-dirs:
     app
 
@@ -87,6 +90,7 @@ executable asmh
     cereal,
     filepath,
     githash,
+    megaparsec,
     optparse-applicative,
     path,
     text,
@@ -110,8 +114,11 @@ test-suite asmh-test
     base >=4.7 && <5,
     bits-show,
     bytestring,
+    filepath,
     megaparsec,
     tasty,
+    tasty-golden,
     tasty-hunit,
     tasty-quickcheck,
     text,
+    text-display,

src/Bin.hs

@@ -1,19 +1,18 @@
 {-# LANGUAGE OverloadedRecordDot #-}
 
-module Bin (writeBin) where
+module Bin (writeBin, compileStatements) where
 
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
+import Data.Char (ord)
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Serialize.Put
-import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.IO qualified as T
 import Data.Vector (Vector)
 import Data.Vector qualified as V
 import Data.Word
-import Debug.Trace
 import Expr
 import System.FilePath
 
@@ -89,46 +88,51 @@ trans labelMap instrLoc = \case
       Just v -> v
     putAsW8 :: RawValue -> Put =
       putWord8 . \case
-        W8 w -> w
-        W16 w -> fromIntegral w
-        IntOrChar w -> fromIntegral w
+        RW8 w -> w
+        RW16 w -> fromIntegral w
+        RInt w -> fromIntegral w
+        RChar w -> fromIntegral $ ord w
 
     putAsW16 :: RawValue -> Put =
       putWord16le . \case
-        W8 w -> fromIntegral w
-        W16 w -> w
-        IntOrChar w -> fromIntegral w
+        RW8 w -> fromIntegral w
+        RW16 w -> w
+        RInt w -> fromIntegral w
+        RChar w -> fromIntegral $ ord w
 
-firstPass :: [Statement] -> ProgramInfo
-firstPass ls = go ls 0 (ProgramInfo mempty mempty mempty)
+compileStatements :: [Statement] -> ByteString
+compileStatements = secondPass . firstPass
   where
-    go :: [Statement] -> Int -> ProgramInfo -> ProgramInfo
-    go [] _offset accum = accum
-    go (x : xs) offset acc = case x of
-      Ins newInstr ->
-        let newOffset = offset + getInstOffset newInstr
-         in go xs newOffset $ acc {instructions = V.snoc acc.instructions newInstr}
-      Dir newDir -> go xs offset $ acc {directives = V.snoc acc.directives newDir}
-      Lab newLabel ->
-        case xs of
-          (Ins _ : _) ->
-            let newInstrPos = offset
-             in go xs offset $ acc {labels = M.insert newLabel newInstrPos acc.labels}
-          _ -> error "there must be a label after an instruction"
+    firstPass :: [Statement] -> ProgramInfo
+    firstPass ls = go ls 0 (ProgramInfo mempty mempty mempty)
+      where
+        go :: [Statement] -> Int -> ProgramInfo -> ProgramInfo
+        go [] _offset accum = accum
+        go (x : xs) offset acc = case x of
+          Ins newInstr ->
+            let newOffset = offset + getInstOffset newInstr
+             in go xs newOffset $ acc {instructions = V.snoc acc.instructions newInstr}
+          Dir newDir -> go xs offset $ acc {directives = V.snoc acc.directives newDir}
+          Lab newLabel ->
+            case xs of
+              (Ins _ : _) ->
+                let newInstrPos = offset
+                 in go xs offset $ acc {labels = M.insert newLabel newInstrPos acc.labels}
+              _ -> error "there must be a label after an instruction"
 
-secondPass :: ProgramInfo -> ByteString
-secondPass = runPut . go 0
-  where
-    go offset p = case V.uncons p.instructions of
-      Just (nextInstruction, rest) -> do
-        let nextInstructionIndex = offset + getInstOffset nextInstruction
-        trans p.labels nextInstructionIndex nextInstruction
-        go nextInstructionIndex (p {instructions = rest})
-      Nothing -> pure ()
+    secondPass :: ProgramInfo -> ByteString
+    secondPass = runPut . go 0
+      where
+        go offset p = case V.uncons p.instructions of
+          Just (nextInstruction, rest) -> do
+            let nextInstructionIndex = offset + getInstOffset nextInstruction
+            trans p.labels nextInstructionIndex nextInstruction
+            go nextInstructionIndex (p {instructions = rest})
+          Nothing -> pure ()
 
 writeBin :: FilePath -> [Statement] -> IO ()
 writeBin originalFileName instr = do
   let newFileName = takeBaseName originalFileName <> ".com"
-  let binaryFile = secondPass $ firstPass instr
+  let binaryFile = compileStatements instr
   B.writeFile newFileName binaryFile
   T.putStrLn $ "Output written to " <> T.pack newFileName

src/Expr.hs

@@ -6,11 +6,17 @@ module Expr
   , Operand (..)
   , Instruction (..)
   , Directive (..)
+  , ToHexString (..)
   )
 where
 
+import Bits.Show (showFiniteBits)
+import Data.String (IsString (..))
 import Data.Text (Text)
+import Data.Text.Display
+import Data.Text.Lazy.Builder (Builder)
 import Data.Word
+import Numeric (showHex)
 import Prelude hiding (take)
 
 data Register
@@ -48,12 +54,41 @@ data Register
     DH
   deriving (Show, Eq)
 
+instance Display Register where
+  {-# INLINE displayBuilder #-}
+  displayBuilder = \case
+    AX -> "AX"
+    BX -> "BX"
+    CX -> "CX"
+    DX -> "DX"
+    SI -> "SI"
+    DI -> "DI"
+    BP -> "BP"
+    SP -> "SP"
+    AL -> "AL"
+    BL -> "BL"
+    CL -> "CL"
+    DL -> "DL"
+    AH -> "AH"
+    BH -> "BH"
+    CH -> "CH"
+    DH -> "DH"
+
 data RawValue
-  = W8 Word8
-  | W16 Word16
-  | IntOrChar Int
+  = RW8 Word8
+  | RW16 Word16
+  | RInt Int
+  | RChar Char
   deriving (Show, Eq)
 
+instance Display RawValue where
+  {-# INLINE displayBuilder #-}
+  displayBuilder = \case
+    RW8 w -> fromString (toHexString w) <> "b"
+    RW16 w -> fromString (toHexString w) <> "b"
+    RInt w -> displayBuilder w
+    RChar w -> "'" <> displayBuilder w <> "'"
+
 type Label = Text
 
 data Statement
@@ -62,13 +97,27 @@ data Statement
   | Lab Label
   deriving (Show, Eq)
 
+instance Display Statement where
+  {-# INLINE displayBuilder #-}
+  displayBuilder = \case
+    Ins x -> displayBuilder x
+    Dir x -> displayBuilder x
+    Lab x -> displayBuilder x
+
 data Operand
   = RegOp Register
   | ImmOp RawValue
   | MemOp Text
   -- TODO: proper memory addresses
   deriving (Show, Eq)
 
+instance Display Operand where
+  {-# INLINE displayBuilder #-}
+  displayBuilder = \case
+    RegOp x -> displayBuilder x
+    ImmOp x -> displayBuilder x
+    MemOp x -> "[" <> displayBuilder x <> "]"
+
 data Instruction
   = MOV Operand Operand
   | ADD Operand Operand
@@ -83,9 +132,51 @@ data Instruction
   | RET
   deriving (Show, Eq)
 
+instance Display Instruction where
+  {-# INLINE displayBuilder #-}
+  displayBuilder = \case
+    MOV x y -> dis "MOV " [x, y]
+    ADD x y -> dis "ADD " [x, y]
+    SUB x y -> dis "SUB " [x, y]
+    OR x y -> dis "OR " [x, y]
+    INT x -> dis "INT " [x]
+    JNS x -> dis "JNS " [x]
+    JMP x -> dis "JMP " [x]
+    INC x -> dis "INC " [x]
+    CMP x y -> dis "CMP " [x, y]
+    JE x -> dis "JE " [x]
+    RET -> dis @Operand "RET" []
+    where
+      dis :: Display x => Builder -> [x] -> Builder
+      dis iname args = iname <> go (if null args then "" else " ") args
+        where
+          go accum [] = accum
+          go accum (x : xs) = go (accum <> ", " <> displayBuilder x) xs
+
 data Directive
   = ORG Word16
   | DB (Either (Text, [Word8]) [Word8])
   | END
   | NAME Text
   deriving (Show, Eq)
+
+instance Display Directive where
+  {-# INLINE displayBuilder #-}
+  displayBuilder = \case
+    ORG w -> "ORG" <> displayBuilder (RW16 w)
+    DB ei -> "TODO NOT DONE"
+    END -> "END"
+    NAME txt -> "NAME \"" <> displayBuilder txt <> "\""
+
+class ToHexString a where
+  toHexString :: a -> String
+
+instance ToHexString Word8 where
+  toHexString w = pad2 $ showHex w ""
+    where
+      pad2 s = replicate (2 - length s) '0' ++ s
+
+instance ToHexString Word16 where
+  toHexString w = pad4 $ showHex w ""
+    where
+      pad4 s = replicate (4 - length s) '0' ++ s

src/Parser.hs

@@ -90,10 +90,10 @@ parseHex12 = parseHex 3
 parseHex16 :: Parser Word16
 parseHex16 = parseHex 4
 
-parseChar :: Parser Int
+parseChar :: Parser Char
 parseChar =
   label "character enclosed in <'>" $
-    ord <$> between "'" "'" anySingle
+    between "'" "'" anySingle
 
 parseDecimal :: Parser Int
 parseDecimal =
@@ -145,10 +145,10 @@ parseOperand =
     , label "immediate value" $
         ImmOp
           <$> choice
-            [ try $ IntOrChar <$> parseDecimal
-            , try $ W16 <$> parseImmediate16
-            , try $ W8 <$> parseImmediate8
-            , IntOrChar <$> parseChar
+            [ try $ RInt <$> parseDecimal
+            , try $ RW16 <$> parseImmediate16
+            , try $ RW8 <$> parseImmediate8
+            , RChar <$> parseChar
             ]
     , label "memory address" $ MemOp <$> parseMemory
     ]
@@ -225,18 +225,14 @@ sc = L.space space1 (L.skipLineComment ";") (L.skipBlockComment "/*" "*/")
 
 -- Main parser function
 parseAssembly
-  :: Text
-  -> Either
-      (ParseErrorBundle Text Void)
-      [Statement]
+  :: FilePath -> Text -> Either (ParseErrorBundle Text Void) [Statement]
 parseAssembly =
   parse
     (sc *> some parseStatement <* eof)
-    "myfile"
 
-mainLocal :: Text -> IO (Maybe [Statement])
-mainLocal assemblyCode = do
-  case parseAssembly assemblyCode of
+parseTestHelper :: Text -> IO (Maybe [Statement])
+parseTestHelper assemblyCode = do
+  case parseAssembly "test" assemblyCode of
     Left err -> do
       putStrLn "Error: "
       putStrLn $ errorBundlePretty err
@@ -247,6 +243,6 @@ mainLocal assemblyCode = do
 
 parseTest :: IO (Maybe [Statement])
 parseTest = do
-  mainLocal "mov ah, \"text3243242moremore\""
+  parseTestHelper "mov ah, \"text3243242moremore\""
 
 -- mainLocal "mov ah, 3243242moremore\""