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).

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