Garmelon/mima-tools
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add garbage ASM format methods

Browse source
This commit is contained in:
I-Al-Istannen 2020-04-01 21:49:02 +02:00
parent 1effa96a17
commit f6859ae578
1 changed files with 82 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

82
src/Mima/Asm/Phase1.hs
View file

@ -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