From 02e23e7d4a9fb2fd2ac5d6b5a75fdcb9471decdb Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 13 Nov 2019 15:22:35 +0000 Subject: [PATCH] Automatically discover .mima-flags files --- app/MimaAsm/Main.hs | 2 +- app/MimaRun/Main.hs | 72 ++++++++++++++++++++++++++++++--------------- package.yaml | 1 + src/Mima/IO.hs | 47 ++++++++++++++++++++++------- src/Mima/Load.hs | 5 ++-- 5 files changed, 89 insertions(+), 38 deletions(-) diff --git a/app/MimaAsm/Main.hs b/app/MimaAsm/Main.hs index a15f9b7..9779e64 100644 --- a/app/MimaAsm/Main.hs +++ b/app/MimaAsm/Main.hs @@ -29,7 +29,7 @@ opts :: ParserInfo Settings opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1 main :: IO () -main = doRun $ do +main = doRun_ $ do settings <- lift $ execParser opts lift $ putStrLn $ "Loading assembly file at " ++ infile settings diff --git a/app/MimaRun/Main.hs b/app/MimaRun/Main.hs index c67b78d..6894481 100644 --- a/app/MimaRun/Main.hs +++ b/app/MimaRun/Main.hs @@ -4,28 +4,31 @@ import Control.Monad import Control.Monad.Trans.Class import qualified Data.Text.IO as T import Options.Applicative +import System.FilePath import Mima.Flag import Mima.IO import Mima.Load +import Mima.Parser.FlagFile import Mima.State import Mima.Util +import Mima.Word import PrintState data Settings = Settings - -- General guff - { infile :: FilePath - , outfile :: Maybe FilePath - , autodiscover :: Bool - , flagfile :: Maybe FilePath - , symbolfile :: Maybe FilePath - -- Run-specific guff - , steps :: Maybe Integer - , norun :: Bool - -- Output format guff - , quiet :: Bool - , sparse :: Bool + -- General + { infile :: FilePath + , outfile :: Maybe FilePath + , discover :: Bool + , flagFile :: Maybe FilePath + , symbolFile :: Maybe FilePath + -- Running + , steps :: Maybe Integer + , norun :: Bool + -- Output + , quiet :: Bool + , sparse :: Bool } deriving (Show) {- Command-line parameters -} @@ -41,9 +44,8 @@ settingsParser = Settings <> metavar "OUTFILE" <> help "If specified, write the memory dump to this file after execution is finished") <*> flag True False - (long "autodiscover" - <> short 'a' - <> help "Automatically try to find the .mima-flags and .mima-symbols files corresponding to the input files") + (long "nodiscover" + <> help "Disable the automatic loading of the .mima-flags and .mima-symbols files") <*> (optional . strOption) (long "flags" <> short 'f' @@ -56,12 +58,10 @@ settingsParser = Settings <> help "A file containing label names and addresses, specified in the .mima-symbols format") <*> (optional . option auto) (long "steps" - <> short 'n' <> metavar "N" <> help "How many instructions to execute (if not specified, runs until HALT or execution exception)") <*> flag False True (long "norun" - <> short 'r' <> help "Don't run the MiMa. Use the initial state for all further actions. Roughly equivalent to -n 0") <*> flag False True (long "quiet" @@ -69,7 +69,6 @@ settingsParser = Settings <> help "Don't print the memory dump") <*> flag False True (long "sparse" - <> short 's' <> help "Don't print memory locations containing only 0x000000 in the memory dump") opts :: ParserInfo Settings @@ -77,31 +76,56 @@ opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1 {- Main logic -} -runMima :: Settings -> MimaState -> IO MimaState -runMima settings s = +runMima :: Settings -> MimaState -> Flags (MimaAddress -> Bool) -> IO MimaState +runMima settings s f = case steps settings of Nothing -> do putStrLn "Running until HALT or execution exception..." - let (s', e, x) = run noFlags s + let (s', e, x) = run f s putStrLn $ "Ran for " ++ show x ++ " steps" T.putStrLn $ toText e pure s' Just n -> do - let (s', me, x) = runN noFlags n s + let (s', me, x) = runN f n s putStrLn $ "Ran for " ++ show x ++ " steps" case me of Nothing -> putStrLn "Encountered no exception" Just e -> T.putStrLn $ toText e pure s' +loadFlagFile :: FilePath -> Run (Flags (MimaAddress -> Bool)) +loadFlagFile filename = flagChecks <$> parseFile parseFlagFile filename + +loadFlags :: Settings -> Run (Flags (MimaAddress -> Bool)) +loadFlags settings = do + case flagFile settings of + Just filename -> do + lift $ putStrLn $ "Loading flags from specified file: " ++ filename + loadFlagFile filename + Nothing -> do + maybeFlags <- if discover settings then tryLoadDiscovered else pure Nothing + case maybeFlags of + Just flags -> pure flags + Nothing -> do + lift $ putStrLn "Not using flags" + pure noFlags + where + discovered = dropExtension (infile settings) ++ ".mima-flags" + tryLoadDiscovered = do + lift $ putStrLn $ "Loading flags from file: " ++ discovered + tryRun (loadFlagFile discovered) + -- TODO exception handling main :: IO () -main = doRun $ do +main = doRun_ $ do settings <- lift $ execParser opts lift $ putStrLn $ "Loading memdump at " ++ infile settings ms <- loadStateFromFile (infile settings) - ms' <- if norun settings then pure ms else lift (runMima settings ms) + + flags <- loadFlags settings + + ms' <- if norun settings then pure ms else lift (runMima settings ms flags) unless (quiet settings) $ do lift $ putStrLn "" diff --git a/package.yaml b/package.yaml index c6327d2..7602e47 100644 --- a/package.yaml +++ b/package.yaml @@ -24,6 +24,7 @@ dependencies: - binary - bytestring - containers +- filepath - megaparsec - optparse-applicative - text diff --git a/src/Mima/IO.hs b/src/Mima/IO.hs index be06831..6ddde71 100644 --- a/src/Mima/IO.hs +++ b/src/Mima/IO.hs @@ -1,32 +1,57 @@ +{-# LANGUAGE MultiWayIf #-} + module Mima.IO ( Run , doRun - , failWith + , doRun_ + , tryRun + , readTextFile , parseFile ) where import Control.Monad.Trans.Class import Control.Monad.Trans.Except +import qualified Data.Text as T import qualified Data.Text.IO as T +import System.IO.Error import Text.Megaparsec import Mima.Parser.Common type Run a = ExceptT String IO a -doRun :: Run () -> IO () -doRun r = do - result <- runExceptT r - case result of - Left errorMsg -> putStrLn errorMsg - Right () -> pure () +doRun :: Run a -> IO (Either String a) +doRun = runExceptT -failWith :: String -> Run a -failWith = except . Left +doRun_ :: Run () -> IO () +doRun_ r = do + result <- doRun r + case result of + Right () -> pure () + Left e -> putStrLn e + +tryRun :: Run a -> Run (Maybe a) +tryRun r = do + result <- lift $ runExceptT r + case result of + Right a -> pure $ Just a + Left e -> do + lift $ putStrLn e + pure Nothing + +readTextFile :: FilePath -> Run T.Text +readTextFile filepath = do + eitherContent <- lift $ catchIOError (Right <$> T.readFile filepath) handleError + except eitherContent + where + isRelevantError e = isAlreadyInUseError e || isDoesNotExistError e || isPermissionError e + handleError e = if isRelevantError e + 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 - content <- lift $ T.readFile filepath + content <- readTextFile filepath case parse parser filepath content of Right a -> pure a - Left errorBundle -> failWith $ errorBundlePretty errorBundle + Left errorBundle -> throwE $ errorBundlePretty errorBundle diff --git a/src/Mima/Load.hs b/src/Mima/Load.hs index 992dfab..aee910e 100644 --- a/src/Mima/Load.hs +++ b/src/Mima/Load.hs @@ -8,6 +8,7 @@ module Mima.Load import Control.Applicative import Control.Monad import Control.Monad.Trans.Class +import Control.Monad.Trans.Except import Data.Binary import qualified Data.ByteString.Lazy as BS @@ -56,10 +57,10 @@ loadStateFromFile :: FilePath -> Run MimaState loadStateFromFile path = do bs <- lift $ BS.readFile path case decodeOrFail bs of - Left ( _, _, e) -> failWith e + Left ( _, _, e) -> throwE e Right (bs', _, ldms) | BS.null bs' -> pure $ unLD ldms - | otherwise -> failWith "Input was not consumed fully" + | otherwise -> throwE "Input was not consumed fully" saveStateToFile :: FilePath -> MimaState -> Run () saveStateToFile path = lift . BS.writeFile path . encode . LD