Introduce Run monad

A monad for nice, pure exceptions. I want to avoid working with IO
exceptions as much as possible.

app/MimaAsm/Main.hs

@@ -1,5 +1,6 @@
 module Main where
 
+import Control.Monad.Trans.Class
 import Options.Applicative
 
 import Mima.Assembler.Parser
@@ -28,14 +29,12 @@ opts :: ParserInfo Settings
 opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1
 
 main :: IO ()
-main = do
+main = doRun $ do
-  settings <- execParser opts
+  settings <- lift $ execParser opts
 
-  putStrLn $ "Loading assembly file at " ++ infile settings
+  lift $ putStrLn $ "Loading assembly file at " ++ infile settings
-  asm <- parseFile parseState (infile settings)
+  (state, _) <- parseFile parseState (infile settings)
-  case asm of
+  lift $ putStrLn "Parsing successful"
-    Nothing -> pure ()
+
-    Just (state, _) -> do
+  lift $ putStrLn $ "Writing result to " ++ outfile settings
-      putStrLn "Parsing successful"
-      putStrLn $ "Writing result to " ++ outfile settings
   saveStateToFile (outfile settings) state

app/MimaRun/Main.hs

@@ -1,10 +1,12 @@
 module Main where
 
 import           Control.Monad
+import           Control.Monad.Trans.Class
 import qualified Data.Text.IO as T
 import           Options.Applicative
 
 import           Mima.Flag
+import           Mima.IO
 import           Mima.Load
 import           Mima.State
 import           Mima.Util
@@ -12,12 +14,18 @@ import           Mima.Util
 import           PrintState
 
 data Settings = Settings
-  { infile     :: String
+  -- General guff
+  { infile       :: FilePath
+  , outfile      :: Maybe FilePath
+  , autodiscover :: Bool
+  , flagfile     :: Maybe FilePath
+  , symbolfile   :: Maybe FilePath
+  -- Run-specific guff
   , steps        :: Maybe Integer
-  , memoryDump :: Maybe FilePath
+  , norun        :: Bool
+  -- Output format guff
   , quiet        :: Bool
   , sparse       :: Bool
-  , norun      :: Bool
   } deriving (Show)
 
 {- Command-line parameters -}
@@ -26,17 +34,35 @@ settingsParser :: Parser Settings
 settingsParser = Settings
   <$> strArgument
       (metavar "INFILE"
-       <> help "The binary memory dump to load and execute")
+       <> help "The memory dump to load and execute")
+  <*> (optional . strOption)
+      (long "out"
+       <> short 'o'
+       <> 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")
+  <*> (optional . strOption)
+      (long "flags"
+       <> short 'f'
+       <> metavar "FLAGFILE"
+       <> help "A file containing extension memory flags, specified in the .mima-flags format")
+  <*> (optional . strOption)
+      (long "symbols"
+       <> short 's'
+       <> metavar "SYMBOLFILE"
+       <> 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)")
-  <*> (optional . strOption)
+  <*> flag False True
-      (long "dump"
+      (long "norun"
-       <> short 'd'
+       <> short 'r'
-       <> metavar "OUTFILE"
+       <> help "Don't run the MiMa. Use the initial state for all further actions. Roughly equivalent to -n 0")
-       <> help "If specified, write the MiMa's binary memory dump to this file after execution is finished")
   <*> flag False True
       (long "quiet"
        <> short 'q'
@@ -45,10 +71,6 @@ settingsParser = Settings
       (long "sparse"
        <> short 's'
        <> help "Don't print memory locations containing only 0x000000 in the memory dump")
-  <*> 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")
 
 opts :: ParserInfo Settings
 opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1
@@ -74,22 +96,19 @@ runMima settings s =
 
 -- TODO exception handling
 main :: IO ()
-main = do
+main = doRun $ do
-  settings <- execParser opts
+  settings <- lift $ execParser opts
 
-  putStrLn $ "Loading memdump at " ++ infile settings
+  lift $ putStrLn $ "Loading memdump at " ++ infile settings
   ms <- loadStateFromFile (infile settings)
-  case ms of
+  ms' <- if norun settings then pure ms else lift (runMima settings ms)
-    Left errorMsg -> putStrLn errorMsg
-    Right s       -> do
-      s' <- if norun settings then pure s else runMima settings s
 
   unless (quiet settings) $ do
-        putStrLn ""
+    lift $ putStrLn ""
-        putStrLn "Dump of MiMa state:"
+    lift $ putStrLn "Dump of MiMa state:"
-        printStateLn (sparse settings) s'
+    lift $ printStateLn (sparse settings) ms'
-        putStrLn ""
+    lift $ putStrLn ""
 
-      forM_ (memoryDump settings) $ \path -> do
+  forM_ (outfile settings) $ \path -> do
-        putStrLn $ "Saving memdump at " ++ path
+    lift $ putStrLn $ "Saving memdump at " ++ path
-        saveStateToFile path s'
+    saveStateToFile path ms'

src/Mima/IO.hs

@@ -1,17 +1,32 @@
 module Mima.IO
-  ( parseFile
+  ( Run
+  , doRun
+  , failWith
+  , parseFile
   ) where
 
+import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Except
 import qualified Data.Text.IO as T
 import           Text.Megaparsec
 
 import           Mima.Parser.Common
 
-parseFile :: Parser a -> FilePath -> IO (Maybe a)
+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 ()
+
+failWith :: String -> Run a
+failWith = except . Left
+
+parseFile :: Parser a -> FilePath -> Run a
 parseFile parser filepath = do
-  content <- T.readFile filepath
+  content <- lift $ T.readFile filepath
   case parse parser filepath content of
-    Right a           -> pure $ Just a
+    Right a           -> pure a
-    Left errorBundle  -> do
+    Left errorBundle  -> failWith $ errorBundlePretty errorBundle
-      putStrLn $ errorBundlePretty errorBundle
-      pure Nothing

src/Mima/Load.hs

@@ -7,11 +7,13 @@ module Mima.Load
 
 import           Control.Applicative
 import           Control.Monad
+import           Control.Monad.Trans.Class
 import           Data.Binary
 import qualified Data.ByteString.Lazy as BS
 
-import           Mima.Word
+import           Mima.IO
 import           Mima.State
+import           Mima.Word
 
 -- To prevent orphan instances and keep the compiler happy
 newtype LD t = LD { unLD :: t }
@@ -50,14 +52,14 @@ instance Binary (LD MimaState) where
     mem <- unLD <$> get
     pure $ LD $ MimaState iar acc ra sp fp mem
 
-loadStateFromFile :: FilePath -> IO (Either String MimaState)
+loadStateFromFile :: FilePath -> Run MimaState
 loadStateFromFile path = do
-  bs <- BS.readFile path
+  bs <- lift $ BS.readFile path
-  pure $ case decodeOrFail bs of
+  case decodeOrFail bs of
-    Left  (  _, _, e) -> Left e
+    Left  (  _, _, e) -> failWith e
     Right (bs', _, ldms)
-      | BS.null bs' -> Right $ unLD ldms
+      | BS.null bs' -> pure $ unLD ldms
-      | otherwise   -> Left "Input was not consumed fully"
+      | otherwise   -> failWith "Input was not consumed fully"
 
-saveStateToFile :: FilePath -> MimaState -> IO ()
+saveStateToFile :: FilePath -> MimaState -> Run ()
-saveStateToFile path = BS.writeFile path . encode . LD
+saveStateToFile path = lift . BS.writeFile path . encode . LD