Do more state formatting

Registers can now be displayed above the memory content.

app/MimaRun/Main.hs

@@ -146,7 +146,7 @@ main :: IO ()
 main = doRun_ $ do
   settings <- lift $ execParser opts
 
-  lift $ putStrLn $ "Loading memdump at " ++ infile settings
+  lift $ putStrLn $ "Loading memdump from " ++ infile settings
   ms <- loadStateFromFile (infile settings)
 
   flags  <- loadFlags settings
@@ -156,7 +156,7 @@ main = doRun_ $ do
     then pure ms
     else lift $ runMima settings ms flags
 
-  unless (quiet settings) $ printState ms flags labels settings
+  unless (quiet settings) $ printState ms' flags labels settings
 
   forM_ (outfile settings) $ \path -> do
     lift $ putStrLn $ "Saving memdump at " ++ path

app/MimaRun/PrintState.hs

@@ -1,124 +0,0 @@
-{-# LANGUAGE MultiWayIf #-}
-
-module PrintState
-  ( printStateLn
-  ) where
-
-import           Control.Monad
-import           Data.Bits
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import           System.Console.ANSI
-
-import           Mima.Format.Common
-import           Mima.Instruction
-import           Mima.State
-import           Mima.Util
-import           Mima.Word
-
-printAddress :: Int -> MimaAddress -> IO ()
-printAddress n addr = do
-  T.putStr $ toHex addr
-  putStr " ("
-  T.putStr $ T.justifyRight n ' ' $ toDec addr
-  putStr ")"
-
-printWord :: Int -> MimaWord -> IO ()
-printWord n word = do
-  T.putStr $ toHex word
-  putStr " ("
-  T.putStr $ T.justifyRight n ' ' $ toDec word
-  putStr ")"
-
--- Color scheme:
--- Red:    HALT
--- Yellow: Instructions for accessing other registers
--- Green:  Instructions that can modify the IAR (jumps)
--- Blue:   Instructions that read from or write to memory
--- Cyan:   Logical operations and calculations that modify the ACC
-printInstruction :: Instruction -> IO ()
-printInstruction (SmallInstruction so lv) = do
-  setSGR [SetConsoleIntensity BoldIntensity]
-  if | so `elem` [JMP, JMN, CALL]              -> setSGR [SetColor Foreground Dull Green]
-     | so `elem` [LDC, LDV, STV, LDIV, STIV]   -> setSGR [SetColor Foreground Vivid Blue]
-     | so `elem` [ADD, AND, OR, XOR, EQL, ADC] -> setSGR [SetColor Foreground Vivid Cyan]
-     | otherwise                               -> pure ()
-  T.putStr $ toText so
-  putStr " "
-  setSGR [SetColor Foreground Vivid Black]
-  T.putStr $ toDec lv
-  setSGR []
-printInstruction (LargeInstruction lo sv) = do
-  setSGR [SetConsoleIntensity BoldIntensity]
-  if | lo == HALT                                     -> setSGR [SetColor Foreground Vivid Red]
-     | lo `elem` [LDRA, STRA, LDSP, STSP, LDFP, STFP] -> setSGR [SetColor Foreground Dull Yellow]
-     | lo == RET                                      -> setSGR [SetColor Foreground Dull Green]
-     | lo `elem` [LDRS, STRS, LDRF, STRF]             -> setSGR [SetColor Foreground Vivid Blue]
-     | lo `elem` [NOT, RAR]                           -> setSGR [SetColor Foreground Vivid Cyan]
-     | otherwise                                      -> pure ()
-  T.putStr $ toText lo
-  when (lo `elem` [LDRS, STRS, LDRF, STRF] || sv /= zeroBits) $ do
-    putStr " "
-    setSGR [SetColor Foreground Vivid Black]
-    T.putStr $ toDec sv
-  setSGR []
-
-printWordWithInstruction :: Int -> MimaWord -> IO ()
-printWordWithInstruction n word = do
-  printWord n word
-  case wordToInstruction word of
-    Left _  -> pure ()
-    Right i -> do
-      putStr ": "
-      printInstruction i
-
-printAddressRegister :: MimaState -> MimaAddress -> IO ()
-printAddressRegister ms addr = do
-  printAddress 8 addr
-  putStr "   ->   "
-  printWordWithInstruction 8 $ readAt addr $ msMemory ms
-
-printRegistersLn :: MimaState -> IO ()
-printRegistersLn ms = do
-  putStr "IAR:  "
-  printAddressRegister ms $ msIAR ms
-  putStrLn ""
-
-  putStr "ACC: "
-  printWord 8 $ msACC ms
-  putStrLn ""
-
-  putStr " RA:  "
-  printAddressRegister ms $ msRA ms
-  putStrLn ""
-
-  putStr " SP:  "
-  printAddressRegister ms $ msSP ms
-  putStrLn ""
-
-  putStr " FP:  "
-  printAddressRegister ms $ msFP ms
-  putStrLn ""
-
-printMemoryLocationLn :: MimaAddress -> MimaWord -> IO ()
-printMemoryLocationLn addr word = do
-  printAddress 7 addr
-  putStr "   ->   "
-  printWord 8 word
-  case wordToInstruction word of
-    Left _  -> pure ()
-    Right i -> do
-      putStr ": "
-      printInstruction i
-  putStrLn ""
-
-printMemoryLn :: Bool -> MimaMemory -> IO ()
-printMemoryLn sparse mem = do
-  let addresses = if sparse then sparseUsedAddresses mem else usedAddresses mem
-  forM_ addresses $ \addr -> do
-    printMemoryLocationLn addr (readAt addr mem)
-
-printStateLn :: Bool -> MimaState -> IO ()
-printStateLn sparse ms = do
-  printRegistersLn ms
-  printMemoryLn sparse $ msMemory ms

src/Mima/Format/State.hs

@@ -13,6 +13,10 @@ module Mima.Format.State
   , fAddress
   -- * Words
   , fWord
+  -- * Memory
+  , fMemory
+  -- * Registers
+  , fRegisters
   -- * The whole state
   , formatState
   ) where
@@ -30,8 +34,9 @@ import           Mima.Word
 
 data FormatConfig = FormatConfig
   { fcSparse            :: Bool
-  , fcShowRegisterFlags :: Bool
+  , fcShowRegisters     :: Bool
   , fcShowMemoryFlags   :: Bool
+  , fcShowRegisterFlags :: Bool
   , fcShowAddressDec    :: Bool
   , fcShowAddressHex    :: Bool
   , fcShowAddressBin    :: Bool
@@ -143,18 +148,65 @@ fMemoryLn a = do
   word <- fWord w
   pure $ flags <> " " <> addr <> " " <> word <> "\n"
 
-fMemory :: Formatter
-fMemory = do
+interestingAddresses :: FormatReader (Set.Set MimaAddress)
+interestingAddresses = do
+  env <- ask
+  let conf = feConf env
+      s = feState env
+  pure $ if fcShowRegisterFlags conf
+    then Set.fromList [msIAR s, msRA s, msSP s, msFP s]
+    else Set.empty
+  
+getAddresses :: FormatReader [MimaAddress]
+getAddresses = do
   env <- ask
   let conf = feConf env
       mem = msMemory $ feState env
-      addrs = if fcSparse conf then sparseUsedAddresses mem else usedAddresses mem 
+  if fcSparse conf
+    then do
+      interesting <- interestingAddresses
+      pure $ Set.toAscList $ Set.union interesting $ Set.fromList $ usedAddresses mem
+    else pure $ usedAddresses mem
+
+fMemory :: Formatter
+fMemory = do
+  addrs <- getAddresses
   mconcat <$> mapM fMemoryLn addrs
 
+{- Registers -}
+
+fAddressRegister :: T.Text -> MimaAddress -> Formatter
+fAddressRegister name addr = do
+  addrText <- fAddress addr
+  pure $ name <> ": " <> addrText <> "\n"
+
+fWordRegister :: T.Text -> MimaWord -> Formatter
+fWordRegister name word = do
+  wordText <- fWord word
+  pure $ name <> ": " <> wordText <> "\n"
+
+fRegisters :: Formatter
+fRegisters = do
+  env <- ask
+  let s = feState env
+  mconcat <$> sequenceA [ fAddressRegister "IAR" (msIAR s)
+                        , fWordRegister    "ACC" (msACC s)
+                        , fAddressRegister " RA" (msRA s)
+                        , fAddressRegister " SP" (msSP s)
+                        , fAddressRegister " FP" (msFP s)
+                        ]
+
 {- And finally, the whole state -}
 
 fState :: Formatter
-fState = fMemory
+fState = do
+  env <- ask
+  let conf = feConf env
+  memText <- ("--< MEMORY >--\n"    <>) <$> fMemory
+  regText <- ("--< REGISTERS >--\n" <>) <$> fRegisters
+  pure $ if fcShowRegisters conf
+    then regText <> memText
+    else memText
 
 formatState :: FormatEnv -> T.Text
 formatState = runReader fState

src/Mima/Options.hs

@@ -36,10 +36,12 @@ formatConfigParser :: Parser FormatConfig
 formatConfigParser = FormatConfig
   <$> hiddenSwitchWithNo "sparse" True
       "Omit uninteresting addresses"
+  <*> hiddenSwitchWithNo "registers" True
+      "Show the contents of registers before the memory dump"
+  <*> hiddenSwitchWithNo "memory-flags" False
+      "For each address, show all registers currently pointing to that address"
   <*> hiddenSwitchWithNo "register-flags" True
       "For each address, show all the memory flags that are active for that address"
-  <*> hiddenSwitchWithNo "memory-flags" True
-      "For each address, show all registers currently pointing to that address"
   <*> hiddenSwitchWithNo "address-dec" True
       "Display addresses in decimal"
   <*> hiddenSwitchWithNo "address-hex" True

src/Mima/State.hs

@@ -6,8 +6,9 @@ module Mima.State
   , mapToMemory
   , wordsToMemory
   , memoryToWords
+  , maxAddress
   , usedAddresses
-  , sparseUsedAddresses
+  , continuousUsedAddresses
   , readAt
   , writeAt
   , MimaState(..)
@@ -24,6 +25,7 @@ import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.Reader
 import           Data.Bits
 import qualified Data.Map.Strict as Map
+import           Data.Maybe
 import qualified Data.Text as T
 
 import           Mima.Flag
@@ -43,16 +45,16 @@ wordsToMemory = mapToMemory
               . zip [minBound..]
 
 memoryToWords :: MimaMemory -> [MimaWord]
-memoryToWords mem = map (\addr -> readAt addr mem) $ usedAddresses mem
+memoryToWords mem = map (\addr -> readAt addr mem) $ continuousUsedAddresses mem
+
+maxAddress :: MimaMemory -> MimaAddress
+maxAddress (MimaMemory m) = fromMaybe minBound $ fst <$> Map.lookupMax m
 
 usedAddresses :: MimaMemory -> [MimaAddress]
-usedAddresses (MimaMemory m) =
-  case fst <$> Map.lookupMax m of
-    Nothing      -> []
-    Just maxAddr -> [minBound..maxAddr]
+usedAddresses (MimaMemory m) = Map.keys m
 
-sparseUsedAddresses :: MimaMemory -> [MimaAddress]
-sparseUsedAddresses (MimaMemory m) = Map.keys m
+continuousUsedAddresses :: MimaMemory -> [MimaAddress]
+continuousUsedAddresses mem = [minBound..maxAddress mem]
 
 readAt :: MimaAddress -> MimaMemory -> MimaWord
 readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m