From 745c201d009b22785528d479c043fdf74e2a2b10 Mon Sep 17 00:00:00 2001 From: Joscha Date: Mon, 25 Nov 2019 14:16:05 +0000 Subject: [PATCH] Fix flag parsing and weeding --- src/Mima/Format/FlagFile.hs | 9 ++++---- src/Mima/Parse/Assembly/Directive.hs | 7 +++--- src/Mima/Parse/Assembly/Lexeme.hs | 2 +- src/Mima/Parse/Assembly/Weed/Statement.hs | 26 +++++++++++++++++------ src/Mima/Parse/Weed.hs | 10 ++++++--- 5 files changed, 37 insertions(+), 17 deletions(-) diff --git a/src/Mima/Format/FlagFile.hs b/src/Mima/Format/FlagFile.hs index 02d7534..4a9e2f9 100644 --- a/src/Mima/Format/FlagFile.hs +++ b/src/Mima/Format/FlagFile.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Mima.Format.FlagFile - ( formatFlagFile + ( formatFlagSet + , formatFlagFile ) where import qualified Data.Map as Map @@ -15,8 +16,8 @@ import Mima.Word fAddress :: MimaAddress -> T.Text fAddress = fixWidthHex 5 . toHex -fFlagSet :: Set.Set Char -> T.Text -fFlagSet = T.pack . Set.toAscList +formatFlagSet :: Set.Set Char -> T.Text +formatFlagSet = T.pack . Set.toAscList fRange :: AddressRange -> T.Text fRange r @@ -27,7 +28,7 @@ fRange r upper = upperAddress r fLine :: (AddressRange, Set.Set Char) -> T.Text -fLine (r, s) = fRange r <> ": " <> fFlagSet s <> "\n" +fLine (r, s) = fRange r <> ": " <> formatFlagSet s <> "\n" formatFlagFile :: RawFlags -> T.Text formatFlagFile = mconcat . map fLine . Map.assocs diff --git a/src/Mima/Parse/Assembly/Directive.hs b/src/Mima/Parse/Assembly/Directive.hs index 62bbcd0..e37ccdc 100644 --- a/src/Mima/Parse/Assembly/Directive.hs +++ b/src/Mima/Parse/Assembly/Directive.hs @@ -8,6 +8,7 @@ module Mima.Parse.Assembly.Directive import qualified Data.Set as Set import Text.Megaparsec +import qualified Text.Megaparsec.Char as C import Mima.Parse.Assembly.Common import Mima.Parse.Assembly.Lexeme @@ -40,7 +41,7 @@ lSetRegister = <|> SetSP <$> sepBySpace "sp" address <|> SetFP <$> sepBySpace "fp" address where - sepBySpace name parser = symbol' name *> lSpace *> lexeme parser + sepBySpace name parser = C.string' name *> lSpace *> lexeme parser lWordArray :: Parser [MimaWord] lWordArray = open *> (word `sepBy` comma) <* close @@ -58,8 +59,8 @@ lDirective = label "assembler directive" $ <|> DOrg <$> directive ".org" (lexeme largeValue) <|> DLit <$> directive ".lit" (lexeme word) <|> DArr <$> directive ".arr" lWordArray - <|> DFlag <$> directive ".flag" lFlags <|> DFlagOn <$> directive ".flagon" lFlags <|> DFlagOff <$> directive ".flagoff" lFlags + <|> DFlag <$> directive ".flag" lFlags where - directive name parser = symbol name *> lSpace *> parser + directive name parser = C.string name *> lSpace *> parser diff --git a/src/Mima/Parse/Assembly/Lexeme.hs b/src/Mima/Parse/Assembly/Lexeme.hs index 1c2a4ed..d7c084a 100644 --- a/src/Mima/Parse/Assembly/Lexeme.hs +++ b/src/Mima/Parse/Assembly/Lexeme.hs @@ -31,7 +31,7 @@ symbol' :: T.Text -> Parser T.Text symbol' = L.symbol' space lSpace :: Parser () -lSpace = lexeme space +lSpace = () <$ lexeme whitespace lNewline :: Parser () lNewline = void $ lexeme C.newline diff --git a/src/Mima/Parse/Assembly/Weed/Statement.hs b/src/Mima/Parse/Assembly/Weed/Statement.hs index 3ea77a9..853ad2e 100644 --- a/src/Mima/Parse/Assembly/Weed/Statement.hs +++ b/src/Mima/Parse/Assembly/Weed/Statement.hs @@ -9,8 +9,10 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.State import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Text as T import Mima.Flag +import Mima.Format.FlagFile import Mima.Label import Mima.Parse.Assembly.Common import Mima.Parse.Assembly.Directive @@ -23,8 +25,8 @@ import Mima.Word data WeedState = WeedState { wsAt :: MimaAddress , wsOccupied :: Bool - , wsLastFlagsAt :: MimaAddress - , wsOpenFlags :: Set.Set Char + , wsLastFlagsAt :: MimaAddress -- The address of the last flags change + , wsOpenFlags :: Set.Set Char -- Which flags are currently active , wsResult :: WeedResult Address } deriving (Show) @@ -109,7 +111,7 @@ pushFlags newFlags = do unless (Set.null wsOpenFlags) $ do let r = range wsLastFlagsAt wsAt modifyResult (\res -> res{wrFlags = Map.insert r wsOpenFlags (wrFlags res)}) - modify (\st -> st{wsOpenFlags = newFlags, wsLastFlagsAt = wsAt}) + modify (\st -> st{wsOpenFlags = newFlags, wsLastFlagsAt = wsAt}) setFlags :: WithOffset a -> Set.Set Char -> SWeed () setFlags thing flags = do @@ -124,7 +126,7 @@ turnFlagsOn :: WithOffset a -> Set.Set Char -> SWeed () turnFlagsOn thing flags = do WeedState{..} <- get let newFlags = Set.union wsOpenFlags flags - when (flags == newFlags) $ + when (wsOpenFlags == newFlags) $ lift $ harmless $ errorAt thing "All flags already active at this address" pushFlags newFlags @@ -132,7 +134,7 @@ turnFlagsOff :: WithOffset a -> Set.Set Char -> SWeed () turnFlagsOff thing flags = do WeedState{..} <- get let newFlags = wsOpenFlags Set.\\ flags - when (flags == newFlags) $ + when (wsOpenFlags == newFlags) $ lift $ harmless $ errorAt thing "All flags already inactive at this address" pushFlags newFlags @@ -160,4 +162,16 @@ weedStep thing = SLabel l -> addLabel thing l weedStatements :: [WithOffset (Statement Address)] -> Weed WeedError (WeedResult Address) -weedStatements statements = wsResult <$> execStateT (mapM_ weedStep statements) initialState +weedStatements statements = do + result <- execStateT (mapM_ weedStep statements) initialState + when (not $ Set.null $ wsOpenFlags result) + $ harmless + $ errorAt' (lastOffset statements) + $ "Flags were never closed: " ++ T.unpack (formatFlagSet (wsOpenFlags result)) + pure $ wsResult result + where + -- Quick and dirty solution, plus I'm too lazy to see if the prelude has a + -- safe head + lastOffset [] = 0 + lastOffset [s] = woOffset s + lastOffset (_:s) = lastOffset s diff --git a/src/Mima/Parse/Weed.hs b/src/Mima/Parse/Weed.hs index c2bf22d..9ae0374 100644 --- a/src/Mima/Parse/Weed.hs +++ b/src/Mima/Parse/Weed.hs @@ -14,6 +14,7 @@ module Mima.Parse.Weed , withOffset , errorAt , errorAt' + , errorsAt' , runWeedBundle ) where @@ -93,10 +94,13 @@ withOffset :: Parser a -> Parser (WithOffset a) withOffset p = WithOffset <$> getOffset <*> p errorAt :: WithOffset a -> String -> WeedError -errorAt wo errorMsg = errorAt' wo [errorMsg] +errorAt wo errorMsg = errorAt' (woOffset wo) errorMsg -errorAt' :: WithOffset a -> [String] -> WeedError -errorAt' wo = FancyError (woOffset wo) . Set.fromList . map ErrorFail +errorAt' :: Int -> String -> WeedError +errorAt' o errorMsg = errorsAt' o [errorMsg] + +errorsAt' :: Int -> [String] -> WeedError +errorsAt' o = FancyError o . Set.fromList . map ErrorFail runWeedBundle :: FilePath -> T.Text -> Weed WeedError a -> Either WeedErrorBundle a runWeedBundle filename input w = case runWeed w of