Format mima state

Also, use the new formatter in mima-run (and while we're at it, clean up flag
file loading and prepare for symbol file loading).

app/MimaRun/Main.hs

@@ -2,20 +2,22 @@ module Main where
 
 import           Control.Monad
 import           Control.Monad.Trans.Class
+import           Control.Monad.Trans.Except
 import qualified Data.Text.IO as T
 import           Options.Applicative
 import           System.FilePath
 
 import           Mima.Flag
+import           Mima.Format.State
 import           Mima.IO
+import           Mima.Label
 import           Mima.Load
+import           Mima.Options
 import           Mima.Parse.FlagFile
 import           Mima.State
 import           Mima.Util
 import           Mima.Word
 
-import           PrintState
-
 data Settings = Settings
   -- General
   { infile     :: FilePath
@@ -28,7 +30,7 @@ data Settings = Settings
   , norun      :: Bool
   -- Output
   , quiet      :: Bool
-  , sparse     :: Bool
+  , formatConf :: FormatConfig
   } deriving (Show)
 
 {- Command-line parameters -}
@@ -43,16 +45,15 @@ settingsParser = Settings
        <> short 'o'
        <> metavar "OUTFILE"
        <> help "If specified, write the memory dump to this file after execution is finished")
-  <*> flag True False
+  <*> switchWithNo "discover" True
-      (long "nodiscover"
+      (help "Disable the automatic loading of the .mima-flags and .mima-symbols files")
-       <> help "Disable the automatic loading of the .mima-flags and .mima-symbols files")
   <*> (optional . strOption)
-      (long "flags"
+      (long "flag-file"
        <> short 'f'
        <> metavar "FLAGFILE"
        <> help "A file containing extension memory flags, specified in the .mima-flags format")
   <*> (optional . strOption)
-      (long "symbols"
+      (long "symbol-file"
        <> short 's'
        <> metavar "SYMBOLFILE"
        <> help "A file containing label names and addresses, specified in the .mima-symbols format")
@@ -67,14 +68,47 @@ settingsParser = Settings
       (long "quiet"
        <> short 'q'
        <> help "Don't print the memory dump")
-  <*> flag False True
+  <*> formatConfigParser
-      (long "sparse"
-       <> help "Don't print memory locations containing only 0x000000 in the memory dump")
 
 opts :: ParserInfo Settings
 opts = info (helper <*> settingsParser) $ fullDesc <> failureCode 1
 
-{- Main logic -}
+{- Loading the flag file -}
+
+-- If explicit file name:
+--   Try to load file
+--   Fail if loading fails
+-- Elif discover:
+--   Try to load file
+--   Use defaults if loading fails
+-- Else:
+--   Use defaults
+
+loadFlagFile :: FilePath -> Run (Flags (MimaAddress -> Bool))
+loadFlagFile filename = do
+  lift $ putStrLn $ "Loading flags from " ++ filename
+  (interpretFlagSpec . getFlagSpec) <$> loadFile readFlagFile filename
+
+withDefaultFlags :: Run (Flags (MimaAddress -> Bool)) -> Run (Flags (MimaAddress -> Bool))
+withDefaultFlags p = do
+  result <- tryRun p
+  case result of
+    Just flags -> pure flags
+    Nothing -> do
+      lift $ putStrLn "Using default flags"
+      pure noFlags
+
+loadFlags :: Settings -> Run (Flags (MimaAddress -> Bool))
+loadFlags settings =
+  case flagFile settings of
+    Just filename -> loadFlagFile filename
+    Nothing -> withDefaultFlags $ if discover settings
+      then loadFlagFile discovered
+      else throwE "File not specified and discovery turned off"
+  where
+    discovered = dropExtension (infile settings) ++ ".mima-flags"
+
+{- Other functions -}
 
 runMima :: Settings -> MimaState -> Flags (MimaAddress -> Bool) -> IO MimaState
 runMima settings s f =
@@ -93,27 +127,18 @@ runMima settings s f =
         Just e  -> T.putStrLn $ toText e
       pure s'
 
-loadFlagFile :: FilePath -> Run (Flags (MimaAddress -> Bool))
+printState :: MimaState -> Flags (MimaAddress -> Bool) -> LabelSpec -> Settings -> Run ()
-loadFlagFile filename = (interpretFlagSpec . getFlagSpec) <$> loadFile readFlagFile filename
+printState ms flags labels settings = do
-
+  let formatEnv = FormatEnv
-loadFlags :: Settings -> Run (Flags (MimaAddress -> Bool))
+        { feState  = ms
-loadFlags settings = do
+        , feFlags  = flags
-  case flagFile settings of
+        , feLabels = labelsByAddress labels
-    Just filename -> do
+        , feConf   = formatConf settings
-      lift $ putStrLn $ "Loading flags from specified file: " ++ filename
+        }
-      loadFlagFile filename
+  lift $ putStrLn ""
-    Nothing -> do
+  lift $ putStrLn "Dump of MiMa state:"
-      maybeFlags <- if discover settings then tryLoadDiscovered else pure Nothing
+  lift $ T.putStrLn $ formatState formatEnv
-      case maybeFlags of
+  lift $ putStrLn ""
-        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 ()
@@ -123,15 +148,14 @@ main = doRun_ $ do
   lift $ putStrLn $ "Loading memdump at " ++ infile settings
   ms <- loadStateFromFile (infile settings)
 
-  flags <- loadFlags settings
+  flags  <- loadFlags settings
+  labels <- pure noLabels -- loadSymbolFile settings
 
-  ms' <- if norun settings then pure ms else lift (runMima settings ms flags)
+  ms' <- if norun settings
+    then pure ms
+    else lift $ runMima settings ms flags
 
-  unless (quiet settings) $ do
+  unless (quiet settings) $ printState ms flags labels settings
-    lift $ putStrLn ""
-    lift $ putStrLn "Dump of MiMa state:"
-    lift $ printStateLn (sparse settings) ms'
-    lift $ putStrLn ""
 
   forM_ (outfile settings) $ \path -> do
     lift $ putStrLn $ "Saving memdump at " ++ path

src/Mima/Format/State.hs

@@ -0,0 +1,176 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Format.State
+  ( FormatConfig(..)
+  , defaultFormatConfig
+  , FormatEnv(..)
+  , FormatReader
+  , Formatter
+  -- * Flags
+  , fRegisterFlags
+  , fMemoryFlags
+  , fFlags
+  -- * Addresses
+  , fAddress
+  -- * Words
+  , fWord
+  -- * The whole state
+  , formatState
+  ) where
+
+import           Control.Monad.Trans.Reader
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as T
+
+import           Mima.Flag
+import           Mima.Format.Common
+import           Mima.Label
+import           Mima.State
+import           Mima.Word
+
+data FormatConfig = FormatConfig
+  { fcSparse            :: Bool
+  , fcShowRegisterFlags :: Bool
+  , fcShowMemoryFlags   :: Bool
+  , fcShowAddressDec    :: Bool
+  , fcShowAddressHex    :: Bool
+  , fcShowAddressBin    :: Bool
+  , fcShowWordDec       :: Bool
+  , fcShowWordHex       :: Bool
+  , fcShowWordBin       :: Bool
+  , fcShowInstructions  :: Bool -- Currently unused
+  , fcShowLabels        :: Bool -- Currently unused
+  } deriving (Show)
+
+defaultFormatConfig :: FormatConfig
+defaultFormatConfig = FormatConfig
+  { fcSparse            = True
+  , fcShowRegisterFlags = True
+  , fcShowMemoryFlags   = True
+  , fcShowAddressDec    = True
+  , fcShowAddressHex    = True
+  , fcShowAddressBin    = False
+  , fcShowWordDec       = True
+  , fcShowWordHex       = True
+  , fcShowWordBin       = False
+  , fcShowInstructions  = True
+  , fcShowLabels        = False
+  }
+
+data FormatEnv = FormatEnv
+  { feState  :: MimaState
+  , feFlags  :: Flags (MimaAddress -> Bool)
+  , feLabels :: Map.Map MimaAddress (Set.Set LabelName)
+  , feConf   :: FormatConfig
+  }
+
+type FormatReader a = Reader FormatEnv a
+type Formatter = FormatReader T.Text
+
+{- Flags -}
+
+flagAt :: (MimaState -> MimaAddress) -> Char -> MimaState -> MimaAddress -> T.Text
+flagAt f c s a = T.singleton $ if f s == a then c else ' '
+
+iarFlag :: MimaState -> MimaAddress -> T.Text
+iarFlag = flagAt msIAR '>'
+
+raFlag :: MimaState -> MimaAddress -> T.Text
+raFlag = flagAt msRA 'R'
+
+spFlag :: MimaState -> MimaAddress -> T.Text
+spFlag = flagAt msSP 'S'
+
+fpFlag :: MimaState -> MimaAddress -> T.Text
+fpFlag = flagAt msFP 'F'
+
+fRegisterFlags :: MimaState -> MimaAddress -> T.Text
+fRegisterFlags s a = mconcat $ [fpFlag, spFlag, raFlag, iarFlag] <*> pure s <*> pure a
+
+fMemoryFlags :: Flags (MimaAddress -> Bool) -> MimaAddress -> T.Text
+fMemoryFlags flags a =
+  let b = if flagBreakpoint flags a then 'b' else ' '
+      e = if flagExecutable flags a then 'e' else ' '
+      r = if flagReadOnly   flags a then 'r' else ' '
+  in  T.pack [b, e, r]
+
+fFlags :: MimaAddress -> Formatter
+fFlags a = do
+  env <- ask
+  let conf = feConf env
+      s = feState env
+      f = feFlags env
+      memoryFlags   = if fcShowMemoryFlags   conf then fMemoryFlags   f a else ""
+      registerFlags = if fcShowRegisterFlags conf then fRegisterFlags s a else ""
+  pure $ memoryFlags <> registerFlags
+
+{- Addresses -}
+
+fAddressBin :: MimaAddress -> T.Text
+fAddressBin = chunkyBin . fixWidthBin (4 * 5) . toBin
+
+fAddressDec :: MimaAddress -> T.Text
+fAddressDec = fixWidthDec 9 . chunkyDec . toDec
+
+fAddressHex :: MimaAddress -> T.Text
+fAddressHex = chunkyHex . fixWidthHex 5 . toHex
+
+fAddress :: MimaAddress -> Formatter
+fAddress a = do
+  env <- ask
+  let conf = feConf env
+      dec = if fcShowAddressDec conf then [fAddressDec] else []
+      hex = if fcShowAddressHex conf then [fAddressHex] else []
+      bin = if fcShowAddressBin conf then [fAddressBin] else []
+      formats = (dec ++ hex ++ bin) <*> pure a
+  pure $ "[" <> T.intercalate "," formats <> "]"
+
+{- Words -}
+
+fWordBin :: MimaWord -> T.Text
+fWordBin = chunkyBin . fixWidthBin (4 * 6) . toBin
+
+fWordDec :: MimaWord -> T.Text
+fWordDec = fixWidthDec 10 . chunkyDec . toDec
+
+fWordHex :: MimaWord -> T.Text
+fWordHex = chunkyHex . fixWidthHex 6 . toHex
+
+fWord :: MimaWord -> Formatter
+fWord a = do
+  env <- ask
+  let conf = feConf env
+      dec = if fcShowWordDec conf then [fWordDec] else []
+      hex = if fcShowWordHex conf then [fWordHex] else []
+      bin = if fcShowWordBin conf then [fWordBin] else []
+      formats = (dec ++ hex ++ bin) <*> pure a
+  pure $ "{" <> T.intercalate "," formats <> "}"
+
+{- Memory -}
+
+fMemoryLn :: MimaAddress -> Formatter
+fMemoryLn a = do
+  env <- ask
+  let mem = msMemory $ feState env
+      w = readAt a mem
+  flags <- fFlags a
+  addr <- fAddress a
+  word <- fWord w
+  pure $ flags <> " " <> addr <> " " <> word <> "\n"
+
+fMemory :: Formatter
+fMemory = do
+  env <- ask
+  let conf = feConf env
+      mem = msMemory $ feState env
+      addrs = if fcSparse conf then sparseUsedAddresses mem else usedAddresses mem 
+  mconcat <$> mapM fMemoryLn addrs
+
+{- And finally, the whole state -}
+
+fState :: Formatter
+fState = fMemory
+
+formatState :: FormatEnv -> T.Text
+formatState = runReader fState

src/Mima/Label.hs

@@ -2,11 +2,12 @@ module Mima.Label
   ( LabelName
   , LabelSpec
   , labelsByAddress
+  , noLabels
   ) where
 
 import qualified Data.Map as Map
-import qualified Data.Text as T
 import qualified Data.Set as Set
+import qualified Data.Text as T
 
 import           Mima.Word
 
@@ -19,3 +20,6 @@ labelsByAddress = ($ Map.empty)
                 . reverse
                 . map (\(l, a) -> Map.insertWith Set.union a (Set.singleton l))
                 . Map.assocs
+
+noLabels :: LabelSpec
+noLabels = Map.empty

src/Mima/Options.hs

@@ -0,0 +1,28 @@
+module Mima.Options
+  ( switchWithNo
+  , formatConfigParser
+  ) where
+
+import Options.Applicative
+
+import Mima.Format.State
+
+switchWithNo :: String -> Bool -> Mod FlagFields Bool -> Parser Bool
+switchWithNo name True  fields = flag' False (long ("no-" ++ name) <> fields)
+                                 <|> flag True True (long name <> fields)
+switchWithNo name False fields = flag' True (long name <> fields)
+                                 <|> flag False False (long ("no-" ++ name) <> fields)
+
+formatConfigParser :: Parser FormatConfig
+formatConfigParser = FormatConfig
+  <$> switchWithNo "sparse" False mempty
+  <*> switchWithNo "register-flags" True mempty
+  <*> switchWithNo "memory-flags" True mempty
+  <*> switchWithNo "address-dec" True mempty
+  <*> switchWithNo "address-hex" True mempty
+  <*> switchWithNo "address-bin" False mempty
+  <*> switchWithNo "word-dec" True mempty
+  <*> switchWithNo "word-hex" True mempty
+  <*> switchWithNo "word-bin" False mempty
+  <*> switchWithNo "instructions" True mempty
+  <*> switchWithNo "labels" True mempty