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

Clean up and fix formatting code

Browse source
This commit is contained in:
Joscha 2020-04-01 20:26:01 +00:00
parent f6859ae578
commit 4f29ee4fff
1 changed files with 57 additions and 74 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -14,24 +14,23 @@ module Mima.Asm.Phase1
, RegisterDirective(..) , RegisterDirective(..)
, JsonValue(..) , JsonValue(..)
, Directive(..) , Directive(..)
, Span(..)
-- * Phase1 -- * Phase1
, Phase1 , Phase1
, parsePhase1 , parsePhase1
, formatPhase1
) where ) where
import Control.Monad import Control.Monad
import Control.Monad.Trans.Writer
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.Aeson.Text as A import qualified Data.Aeson.Text as A
import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy as BS
import Data.Char import Data.Char
import Data.Foldable import Data.Foldable
import Data.List
import Data.Maybe import Data.Maybe
import Data.Monoid
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy as TL
import Data.Void import Data.Void
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
@ -184,21 +183,15 @@ instance Onion AsmToken where
peel (TokenDirective a) = peel a peel (TokenDirective a) = peel a
peel (TokenComment a _ _) = a peel (TokenComment a _ _) = a
{- Parsers -} data Span = Span SourcePos SourcePos
deriving (Show)
type Phase1 = [AsmToken Span] type Phase1 = [AsmToken Span]
{- Parsing -}
type Parser = Parsec Void T.Text type Parser = Parsec Void T.Text
data Span = Span SourcePos SourcePos
instance Show Span where
show (Span start stop)
= "[" ++ formatSourcePos start ++ " - " ++ formatSourcePos stop ++ "]"
where
formatSourcePos sp
= formatPos (sourceLine sp) ++ ":" ++ formatPos (sourceColumn sp)
formatPos = show . unPos
inlineSpace :: Parser () inlineSpace :: Parser ()
inlineSpace = void $ takeWhileP (Just "space (no newline)") (\x -> isSpace x && x /= '\n') inlineSpace = void $ takeWhileP (Just "space (no newline)") (\x -> isSpace x && x /= '\n')
@ -324,14 +317,14 @@ directive =
metaStart Meta ".meta" metaStart Meta ".meta"
where where
arr = do arr = do
(outerSpan, (regSpan, words)) <- withSpan $ do (outerSpan, (regSpan, mimaWords)) <- withSpan $ do
(dirSpan, _) <- withSpan $ chunk ".arr" (dirSpan, _) <- withSpan $ chunk ".arr"
inlineSpace1 inlineSpace1
words <- between (char '[') (char ']') $ mimaWords <- between (char '[') (char ']') $
sepBy1 mimaWord (char ',' *> inlineSpace) sepBy1 mimaWord (char ',' *> inlineSpace)
pure (dirSpan, words) pure (dirSpan, mimaWords)
pure $ Arr outerSpan regSpan mimaWords
pure $ Arr outerSpan regSpan words
metaStart f keyword = do metaStart f keyword = do
(outerSpan, (regSpan, metaName, jsonValue)) <- withSpan $ do (outerSpan, (regSpan, metaName, jsonValue)) <- withSpan $ do
(dirSpan, _) <- withSpan $ chunk keyword (dirSpan, _) <- withSpan $ chunk keyword
@ -347,11 +340,10 @@ directive =
Right value -> pure value Right value -> pure value
pure (dirSpan, metaName, JsonValue valueSpan rawJsonValue) pure (dirSpan, metaName, JsonValue valueSpan rawJsonValue)
pure $ f outerSpan regSpan metaName jsonValue pure $ f outerSpan regSpan metaName jsonValue
comment :: Bool -> Parser (AsmToken Span) comment :: Bool -> Parser (AsmToken Span)
comment inline = fmap (\(span, text) -> TokenComment span text inline) $ withSpan $ comment inline = fmap (\(s, text) -> TokenComment s text inline) $ withSpan $
char ';' *> takeWhileP (Just "comment") (/= '\n') char ';' *> takeWhileP (Just "comment") (/= '\n')
asmToken :: Parser (AsmToken Span) asmToken :: Parser (AsmToken Span)
@ -389,39 +381,8 @@ parsePhase1 = mconcat <$> sepBy lineParser newline <* eof
{- Formatting -} {- Formatting -}
formatPhase1 :: Phase1 -> T.Text formatName :: Name a -> T.Text
formatPhase1 = T.tail . mconcat . map formatSingle formatName (Name _ text) = text
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 :: Address a -> T.Text
formatAddress (AddressAbsolute _ addr) = toDec addr formatAddress (AddressAbsolute _ addr) = toDec addr
@ -429,10 +390,31 @@ formatAddress (AddressRelative _ rel)
| rel >= 0 = T.pack $ "+" ++ show rel | rel >= 0 = T.pack $ "+" ++ show rel
| otherwise = T.pack $ show rel | otherwise = T.pack $ show rel
formatLocation :: Location a -> T.Text
formatLocation (LocationAddress addr) = formatAddress addr
formatLocation (LocationLabel l) = formatName l
formatSmallOpcode :: SmallOpcode a -> T.Text
formatSmallOpcode (SmallOpcode _ opcode) = T.pack $ show opcode
formatLargeOpcode :: LargeOpcode a -> T.Text
formatLargeOpcode (LargeOpcode _ opcode) = T.pack $ show opcode
formatMimaWord :: MimaWord a -> T.Text formatMimaWord :: MimaWord a -> T.Text
formatMimaWord (WordRaw _ word) = toDec word formatMimaWord (WordRaw _ word) = toDec word
formatMimaWord (WordLocation loc) = formatLocation loc formatMimaWord (WordLocation loc) = formatLocation loc
formatSmallValue :: SmallValue a -> T.Text
formatSmallValue (SmallValue _ val) = toDec val
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
formatRegisterDirective :: RegisterDirective a -> T.Text formatRegisterDirective :: RegisterDirective a -> T.Text
formatRegisterDirective (RegIar _ _ loc) = "IAR " <> formatLocation loc formatRegisterDirective (RegIar _ _ loc) = "IAR " <> formatLocation loc
formatRegisterDirective (RegAcc _ _ word) = "ACC " <> formatMimaWord word formatRegisterDirective (RegAcc _ _ word) = "ACC " <> formatMimaWord word
@ -440,27 +422,28 @@ formatRegisterDirective (RegRa _ _ loc) = "RA " <> formatLocation loc
formatRegisterDirective (RegSp _ _ loc) = "SP " <> formatLocation loc formatRegisterDirective (RegSp _ _ loc) = "SP " <> formatLocation loc
formatRegisterDirective (RegFp _ _ loc) = "FP " <> formatLocation loc formatRegisterDirective (RegFp _ _ loc) = "FP " <> formatLocation loc
formatJsonValue :: JsonValue a -> T.Text
formatJsonValue (JsonValue _ val) = TL.toStrict $ A.encodeToLazyText val
formatDirective :: Directive a -> T.Text formatDirective :: Directive a -> T.Text
formatDirective (Reg _ _ regDir) = ".reg " <> formatRegisterDirective regDir formatDirective (Reg _ _ regDir) = ".reg " <> formatRegisterDirective regDir
formatDirective (Org _ _ addr) = ".org " <> formatAddress addr formatDirective (Org _ _ addr) = ".org " <> formatAddress addr
formatDirective (Lit _ _ val) = ".lit " <> formatMimaWord val formatDirective (Lit _ _ val) = ".lit " <> formatMimaWord val
formatDirective (Arr _ _ vals) = formatDirective (Arr _ _ vals) =
".arr [" <> T.intercalate ", " (map formatMimaWord vals) <> "]" ".arr [" <> T.intercalate ", " (map formatMimaWord vals) <> "]"
formatDirective (Meta _ _ name val) = formatDirective (Meta _ _ n val) =
".meta " <> formatAsName name <> " " <> formatJson val ".meta " <> formatName n <> " " <> formatJsonValue val
formatDirective (MetaStart _ _ name val) = formatDirective (MetaStart _ _ n val) =
".meta-start " <> formatAsName name <> " " <> formatJson val ".meta-start " <> formatName n <> " " <> formatJsonValue val
formatDirective (MetaStop _ _ name) = ".meta-stop " <> formatAsName name formatDirective (MetaStop _ _ n) = ".meta-stop " <> formatName n
formatJson :: JsonValue a -> T.Text formatToken :: AsmToken a -> T.Text
formatJson (JsonValue _ val) = LT.toStrict $ A.encodeToLazyText val formatToken (TokenLabel n) = formatName n <> ":"
formatToken (TokenInstruction ins) = " " <> formatInstruction ins
formatToken (TokenDirective dir) = formatDirective dir
formatToken (TokenComment _ text _) = ";" <> text
roundTrip :: T.Text -> T.Text formatPhase1 :: Phase1 -> T.Text
roundTrip input = case parse parsePhase1 "" input of formatPhase1 (x:y@(TokenComment _ _ True):xs) = formatToken x <> " " <> formatPhase1 (y:xs)
Left err -> T.pack $ errorBundlePretty err formatPhase1 (x:xs) = formatToken x <> "\n" <> formatPhase1 xs
Right val -> formatPhase1 val formatPhase1 [] = ""
displayParse :: T.Text -> IO ()
displayParse input = case parse parsePhase1 "" input of
Left err -> putStrLn $ errorBundlePretty err
Right val -> traverse_ print val