Automatically discover .mima-flags files

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

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

package.yaml

@@ -24,6 +24,7 @@ dependencies:
 - binary
 - bytestring
 - containers
+- filepath
 - megaparsec
 - optparse-applicative
 - text

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

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