diff --git a/app/MimaAsm/Main.hs b/app/MimaAsm/Main.hs index 9779e64..5fddc95 100644 --- a/app/MimaAsm/Main.hs +++ b/app/MimaAsm/Main.hs @@ -33,7 +33,7 @@ main = doRun_ $ do settings <- lift $ execParser opts lift $ putStrLn $ "Loading assembly file at " ++ infile settings - (state, _) <- parseFile parseState (infile settings) + (state, _) <- loadFile readState (infile settings) lift $ putStrLn "Parsing successful" lift $ putStrLn $ "Writing result to " ++ outfile settings diff --git a/app/MimaRun/Main.hs b/app/MimaRun/Main.hs index f178c56..e825ad9 100644 --- a/app/MimaRun/Main.hs +++ b/app/MimaRun/Main.hs @@ -94,7 +94,7 @@ runMima settings s f = pure s' loadFlagFile :: FilePath -> Run (Flags (MimaAddress -> Bool)) -loadFlagFile filename = flagChecks <$> parseFile parseFlagFile filename +loadFlagFile filename = (interpretFlagSpec . getFlagSpec) <$> loadFile readFlagFile filename loadFlags :: Settings -> Run (Flags (MimaAddress -> Bool)) loadFlags settings = do diff --git a/src/Mima/Assembler/Parser.hs b/src/Mima/Assembler/Parser.hs index 0c19e6d..bff4fae 100644 --- a/src/Mima/Assembler/Parser.hs +++ b/src/Mima/Assembler/Parser.hs @@ -2,6 +2,7 @@ module Mima.Assembler.Parser ( parseState + , readState ) where import Control.Monad @@ -18,6 +19,7 @@ import Mima.Assembler.Parser.Instruction import Mima.Assembler.Parser.Label import Mima.Assembler.Parser.RawInstruction import Mima.Assembler.Parser.Register +import Mima.Parse.Weed import Mima.State import Mima.Word @@ -112,3 +114,6 @@ parseState = do let mem = mapToMemory $ Map.map rawInstructionToWord rawInstructions labelNames = Map.fromList $ map (\(k, v) -> (lName k, v)) $ Map.toList labels pure (stateFromRegisters registers mem, labelNames) + +readState :: FilePath -> T.Text -> Either WeedErrorBundle (MimaState, Map.Map T.Text MimaAddress) +readState filename input = parse parseState filename input diff --git a/src/Mima/Flag.hs b/src/Mima/Flag.hs index 064d8ec..3b6f9d4 100644 --- a/src/Mima/Flag.hs +++ b/src/Mima/Flag.hs @@ -15,11 +15,13 @@ module Mima.Flag , specNull , specContains , Flag(..) - , allFlags , flagChar , Flags(..) , rawFlags - , flagChecks + , AllFlags + , FlagSpec + , getFlagSpec + , interpretFlagSpec , noFlags ) where @@ -78,9 +80,6 @@ specContains as addr = any (`rangeContains` addr) $ specToRanges as data Flag = Breakpoint | Executable | ReadOnly deriving (Show, Eq, Ord) -allFlags :: [Flag] -allFlags = [Breakpoint, Executable, ReadOnly] - flagChar :: Flag -> Char flagChar Breakpoint = 'b' flagChar Executable = 'e' @@ -114,18 +113,26 @@ rawFlags = Flags , flagReadOnly = ReadOnly } -flagChecks :: Map.Map AddressRange (Set.Set Flag) -> Flags (MimaAddress -> Bool) -flagChecks m = - let getAddressSpec :: Flag -> AddressSpec - getAddressSpec f = rangesToSpec $ map fst $ filter (Set.member f . snd) $ Map.assocs m +type AllFlags = Map.Map AddressRange (Set.Set Char) +type FlagSpec = Flags AddressSpec - conditions :: Flags (AddressSpec -> MimaAddress -> Bool) +getFlagSpec :: AllFlags -> FlagSpec +getFlagSpec af = + let isInSet :: Flag -> Set.Set Char -> Bool + isInSet f s = flagChar f `Set.member` s + getAddressSpec :: Flag -> AddressSpec + getAddressSpec f = rangesToSpec $ map fst $ filter (isInSet f . snd) $ Map.assocs af + in pure getAddressSpec <*> rawFlags + +interpretFlagSpec :: FlagSpec -> Flags (MimaAddress -> Bool) +interpretFlagSpec spec = + let conditions :: Flags (AddressSpec -> MimaAddress -> Bool) conditions = Flags { flagBreakpoint = specContains , flagExecutable = \as -> if specNull as then const True else specContains as , flagReadOnly = specContains } - in conditions <*> (getAddressSpec <$> rawFlags) + in conditions <*> spec -- | These checks should behave as if no flags were set at all. noFlags :: Flags (MimaAddress -> Bool) diff --git a/src/Mima/IO.hs b/src/Mima/IO.hs index 6aa0482..57007d1 100644 --- a/src/Mima/IO.hs +++ b/src/Mima/IO.hs @@ -6,7 +6,7 @@ module Mima.IO , doRun_ , tryRun , readTextFile - , parseFile + , loadFile ) where import Control.Monad.Trans.Class @@ -16,7 +16,7 @@ import qualified Data.Text.IO as T import System.IO.Error import Text.Megaparsec -import Mima.Parse.Common +import Mima.Parse.Weed type Run a = ExceptT String IO a @@ -49,9 +49,9 @@ readTextFile filepath = do then pure $ Left $ "Can't load file " ++ filepath ++ ": " ++ ioeGetErrorString e else ioError e -- This error does not concern us -parseFile :: Parser a -> FilePath -> Run a -parseFile parser filepath = do +loadFile :: (FilePath -> T.Text -> Either WeedErrorBundle a) -> FilePath -> Run a +loadFile f filepath = do content <- readTextFile filepath - case parse parser filepath content of - Right a -> pure a + case f filepath content of Left errorBundle -> throwE $ errorBundlePretty errorBundle + Right a -> pure a diff --git a/src/Mima/Parse/FlagFile.hs b/src/Mima/Parse/FlagFile.hs index b221225..33336a2 100644 --- a/src/Mima/Parse/FlagFile.hs +++ b/src/Mima/Parse/FlagFile.hs @@ -2,32 +2,29 @@ module Mima.Parse.FlagFile ( parseFlagFile + , readFlagFile ) where import Control.Monad import Data.Char import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Text as T import Text.Megaparsec import Mima.Flag import Mima.Parse.Common import Mima.Parse.Lexeme +import Mima.Parse.Weed import Mima.Word lAddress :: Parser MimaAddress lAddress = lexeme fixedWidthHexAddress -lFlag :: Parser (Set.Set Flag) -lFlag = - -- Not sure if there's a better way than writing the fold - -- explicitly. Mconcat doesn't seem to do the trick. - let knownFlags = foldl (<|>) empty - $ map (\f -> Set.singleton f <$ single (flagChar f)) allFlags - otherFlags = label "alphanumeric character" $ Set.empty <$ satisfy isAlphaNum - in lexeme $ knownFlags <|> otherFlags +lFlag :: Parser (Set.Set Char) +lFlag = lexeme $ label "alphanumeric character" $ Set.singleton <$> satisfy isAlphaNum -lFlags :: Parser (Set.Set Flag) +lFlags :: Parser (Set.Set Char) lFlags = Set.unions <$> some lFlag lAddressRange :: Parser AddressRange @@ -37,7 +34,7 @@ lAddressRange = do void $ symbol ":" pure $ range firstAddress secondAddress -lLine :: Parser (AddressRange, Set.Set Flag) +lLine :: Parser (AddressRange, Set.Set Char) lLine = do a <- lAddressRange void $ symbol ":" @@ -45,5 +42,8 @@ lLine = do hidden lNewlines pure (a, f) -parseFlagFile :: Parser (Map.Map AddressRange (Set.Set Flag)) +parseFlagFile :: Parser AllFlags parseFlagFile = space *> many lNewline *> (Map.fromList <$> many lLine) <* hidden eof + +readFlagFile :: FilePath -> T.Text -> Either WeedErrorBundle AllFlags +readFlagFile filename input = parse parseFlagFile filename input diff --git a/src/Mima/Parse/SymbolFile.hs b/src/Mima/Parse/SymbolFile.hs index ec8a78e..85f6361 100644 --- a/src/Mima/Parse/SymbolFile.hs +++ b/src/Mima/Parse/SymbolFile.hs @@ -3,7 +3,7 @@ module Mima.Parse.SymbolFile ( parseSymbolFile , weedSymbolFile - , loadSymbolFile + , readSymbolFile ) where import Control.Monad @@ -68,7 +68,7 @@ weedSymbolFile m = let pairs = [(l, a) | (a, ls) <- Map.assocs m, l <- ls] in wBuildMap pairs -loadSymbolFile :: FilePath -> T.Text -> Either WeedErrorBundle (Map.Map LabelName MimaAddress) -loadSymbolFile filename input = do +readSymbolFile :: FilePath -> T.Text -> Either WeedErrorBundle (Map.Map LabelName MimaAddress) +readSymbolFile filename input = do unweeded <- parse parseSymbolFile filename input runWeedBundle filename input $ weedSymbolFile unweeded