diff --git a/src/Mima/Asm/Phase1.hs b/src/Mima/Asm/Phase1.hs index ecbcad4..27525dd 100644 --- a/src/Mima/Asm/Phase1.hs +++ b/src/Mima/Asm/Phase1.hs @@ -22,18 +22,22 @@ module Mima.Asm.Phase1 import Control.Monad import Control.Monad.Trans.Writer import qualified Data.Aeson as A +import qualified Data.Aeson.Text as A import qualified Data.ByteString.Lazy as BS import Data.Char import Data.Foldable +import Data.List import Data.Maybe import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT import Data.Void import Text.Megaparsec import Text.Megaparsec.Char import Text.Megaparsec.Char.Lexer hiding (space) +import Mima.Format import qualified Mima.Vm.Instruction as Vm import qualified Mima.Vm.Word as Vm @@ -382,3 +386,81 @@ lineParser = do parsePhase1 :: Parser Phase1 parsePhase1 = mconcat <$> sepBy lineParser newline <* eof + +{- Formatting -} + +formatPhase1 :: Phase1 -> T.Text +formatPhase1 = T.tail . mconcat . map formatSingle + where + formatSingle (TokenLabel name) = "\n" <> formatAsLabel name + formatSingle (TokenInstruction ins) = "\n " <> formatInstruction ins + formatSingle (TokenDirective dir) = "\n" <> formatDirective dir + formatSingle (TokenComment _ text inline) = (if inline then " " else "\n") <> ";" <> text + +formatAsLabel :: Name a -> T.Text +formatAsLabel (Name _ text) = text <> ": " + +formatAsName :: Name a -> T.Text +formatAsName (Name _ text) = text + +formatInstruction :: Instruction a -> T.Text +formatInstruction (SmallInstruction _ opcode loc) + = formatSmallOpcode opcode <> " " <> formatLocation loc +formatInstruction (LargeInstruction _ opcode Nothing) = formatLargeOpcode opcode +formatInstruction (LargeInstruction _ opcode (Just val)) + = formatLargeOpcode opcode <> " " <> formatSmallValue val + +formatSmallOpcode :: SmallOpcode a -> T.Text +formatSmallOpcode (SmallOpcode _ opcode) = T.pack $ show opcode + +formatLargeOpcode :: LargeOpcode a -> T.Text +formatLargeOpcode (LargeOpcode _ opcode) = T.pack $ show opcode + +formatLocation :: Location a -> T.Text +formatLocation (LocationAddress address) = formatAddress address +formatLocation (LocationLabel label) = formatAsLabel label + +formatSmallValue :: SmallValue a -> T.Text +formatSmallValue (SmallValue _ val) = toDec val + +formatAddress :: Address a -> T.Text +formatAddress (AddressAbsolute _ addr) = toDec addr +formatAddress (AddressRelative _ rel) + | rel >= 0 = T.pack $ "+" ++ show rel + | otherwise = T.pack $ show rel + +formatMimaWord :: MimaWord a -> T.Text +formatMimaWord (WordRaw _ word) = toDec word +formatMimaWord (WordLocation loc) = formatLocation loc + +formatRegisterDirective :: RegisterDirective a -> T.Text +formatRegisterDirective (RegIar _ _ loc) = "IAR " <> formatLocation loc +formatRegisterDirective (RegAcc _ _ word) = "ACC " <> formatMimaWord word +formatRegisterDirective (RegRa _ _ loc) = "RA " <> formatLocation loc +formatRegisterDirective (RegSp _ _ loc) = "SP " <> formatLocation loc +formatRegisterDirective (RegFp _ _ loc) = "FP " <> formatLocation loc + +formatDirective :: Directive a -> T.Text +formatDirective (Reg _ _ regDir) = ".reg " <> formatRegisterDirective regDir +formatDirective (Org _ _ addr) = ".org " <> formatAddress addr +formatDirective (Lit _ _ val) = ".lit " <> formatMimaWord val +formatDirective (Arr _ _ vals) = + ".arr [" <> T.intercalate ", " (map formatMimaWord vals) <> "]" +formatDirective (Meta _ _ name val) = + ".meta " <> formatAsName name <> " " <> formatJson val +formatDirective (MetaStart _ _ name val) = + ".meta-start " <> formatAsName name <> " " <> formatJson val +formatDirective (MetaStop _ _ name) = ".meta-stop " <> formatAsName name + +formatJson :: JsonValue a -> T.Text +formatJson (JsonValue _ val) = LT.toStrict $ A.encodeToLazyText val + +roundTrip :: T.Text -> T.Text +roundTrip input = case parse parsePhase1 "" input of + Left err -> T.pack $ errorBundlePretty err + Right val -> formatPhase1 val + +displayParse :: T.Text -> IO () +displayParse input = case parse parsePhase1 "" input of + Left err -> putStrLn $ errorBundlePretty err + Right val -> traverse_ print val