From 5fdbf2fbd27f2e4cacfe8c42a0067db711a39a32 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 6 Nov 2019 15:59:08 +0000 Subject: [PATCH] Improve formatting of various elements Couldn't think of a better commit message --- src/Mima/Instruction.hs | 2 +- src/Mima/State.hs | 37 +++++++++++++++++++++++++++---- src/Mima/Util.hs | 4 ++++ src/Mima/Word.hs | 48 ++++++++++++++++++++++++++++++++--------- 4 files changed, 76 insertions(+), 15 deletions(-) diff --git a/src/Mima/Instruction.hs b/src/Mima/Instruction.hs index 37d515d..696475b 100644 --- a/src/Mima/Instruction.hs +++ b/src/Mima/Instruction.hs @@ -63,7 +63,7 @@ data Instruction deriving (Show, Eq) instance ToText Instruction where - toText (SmallInstruction oc addr) = toText oc <> " " <> toText addr + toText (SmallInstruction oc addr) = toText oc <> " 0x" <> addrToHex addr toText (LargeInstruction oc) = toText oc diff --git a/src/Mima/State.hs b/src/Mima/State.hs index c08854f..755feb4 100644 --- a/src/Mima/State.hs +++ b/src/Mima/State.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + module Mima.State ( MimaMemory , wordsToMemory , memoryToWords + , memoryToText , readAt , writeAt , MimaState(..) @@ -18,18 +21,35 @@ import Data.Maybe import qualified Data.Text as T import Mima.Instruction +import Mima.Util import Mima.Word newtype MimaMemory = MimaMemory (Map.Map MimaAddress MimaWord) deriving (Show) +addressRange :: MimaMemory -> [MimaAddress] +addressRange (MimaMemory m) = + let maxAddr = fromMaybe minBound $ fst <$> Map.lookupMax m + in [minBound..maxAddr] + wordsToMemory :: [MimaWord] -> MimaMemory wordsToMemory = MimaMemory . Map.fromAscList . zip [minBound..] memoryToWords :: MimaMemory -> [MimaWord] -memoryToWords mem@(MimaMemory m) = - let maxAddr = fromMaybe minBound $ fst <$> Map.lookupMax m - in map (\addr -> readAt addr mem) [minBound..maxAddr] +memoryToWords mem = map (\addr -> readAt addr mem) $ addressRange mem + +addressWordToText :: MimaAddress -> MimaWord -> T.Text +addressWordToText addr word = + addrToHex addr <> " (" <> addrToDec addr <> ") - " <> wordToHex word <> " (" <> wordToDec word <> ")" + +memoryToText :: Bool -> MimaMemory -> T.Text +memoryToText sparse mem@(MimaMemory m) + = T.intercalate "\n" + $ map (\addr -> addressWordToText addr (readAt addr mem)) + $ addresses sparse + where + addresses False = addressRange mem + addresses True = Map.keys m readAt :: MimaAddress -> MimaMemory -> MimaWord readAt addr (MimaMemory m) = Map.findWithDefault zeroBits addr m @@ -55,9 +75,18 @@ initialState mem = MimaState data AbortReason = Halted | InvalidInstruction T.Text | InvalidNextIpAddress deriving (Show) +instance ToText AbortReason where + toText Halted = "Halted" + toText (InvalidInstruction t) = "Invalid instruction: " <> t + toText InvalidNextIpAddress = "Invalid next IP address" + data ExecException = ExecException MimaAddress MimaWord AbortReason deriving (Show) +instance ToText ExecException where + toText (ExecException addr word reason) = + "Exception at " <> addrToHexDec addr <> " with word " <> wordToHexDec word <> ": " <> toText reason + incrementIp :: MimaState -> Either ExecException MimaState incrementIp ms = let addr = msIp ms @@ -81,7 +110,7 @@ step ms = do (LargeInstruction oc) -> executeLargeOpcode oc ms executeSmallOpcode :: SmallOpcode -> MimaAddress -> MimaState -> Either ExecException MimaState -executeSmallOpcode LDC addr ms = incrementIp ms{msAcc = addressToWord addr} +executeSmallOpcode LDC addr ms = incrementIp ms{msAcc = addrToWord addr} executeSmallOpcode LDV addr ms = incrementIp ms{msAcc = readAt addr (msMemory ms)} executeSmallOpcode STV addr ms = incrementIp ms{msMemory = writeAt addr (msAcc ms) (msMemory ms)} executeSmallOpcode ADD addr ms = incrementIp ms{msAcc = addWords (msAcc ms) (readAt addr $ msMemory ms)} diff --git a/src/Mima/Util.hs b/src/Mima/Util.hs index 44f18bf..80d9209 100644 --- a/src/Mima/Util.hs +++ b/src/Mima/Util.hs @@ -1,5 +1,6 @@ module Mima.Util ( ToText(..) + , toDec , toHex ) where @@ -19,5 +20,8 @@ import qualified Numeric as N class ToText a where toText :: a -> T.Text +toDec :: (Integral a, Show a) => Int -> a -> T.Text +toDec digits a = T.justifyRight digits ' ' $ T.pack $ show a + toHex :: (Integral a, Show a) => Int -> a -> T.Text toHex digits a = T.justifyRight digits '0' $ T.pack $ N.showHex a "" diff --git a/src/Mima/Word.hs b/src/Mima/Word.hs index d16028f..b483e7b 100644 --- a/src/Mima/Word.hs +++ b/src/Mima/Word.hs @@ -1,17 +1,33 @@ {-# LANGUAGE OverloadedStrings #-} module Mima.Word - ( MimaWord + ( + -- * MiMa-Word + MimaWord + -- ** Formatting + , wordToDec + , wordToHex + , wordToHexDec + -- ** Converting , bytesToWord , wordToBytes , boolToWord + -- ** Querying + , wordSize , topBit , upperOpcode , lowerOpcode , address + -- ** Adding , addWords + -- * MiMa-Addresses , MimaAddress - , addressToWord + -- ** Formatting + , addrToDec + , addrToHex + , addrToHexDec + -- ** Converting + , addrToWord ) where import Data.Bits @@ -35,11 +51,17 @@ newtype MimaWord = MimaWord Word32 wordSize :: Int wordSize = 24 -instance ToText MimaWord where - toText (MimaWord w) = toHex 6 w +wordToDec :: MimaWord -> T.Text +wordToDec (MimaWord w) = toDec 8 w + +wordToHex :: MimaWord -> T.Text +wordToHex (MimaWord w) = toHex 6 w + +wordToHexDec :: MimaWord -> T.Text +wordToHexDec mw = wordToHex mw <> " (" <> wordToDec mw <> ")" instance Show MimaWord where - show mw = T.unpack $ "MimaWord 0x" <> toText mw + show mw = T.unpack $ "MimaWord 0x" <> wordToHex mw instance Word32Based MimaWord where fromWord32 w = MimaWord $ w .&. 0x00FFFFFF @@ -115,11 +137,17 @@ addWords mw1 mw2 = fromWord32 $ toWord32 mw1 + toWord32 mw2 newtype MimaAddress = MimaAddress Word32 deriving (Eq, Ord) -instance ToText MimaAddress where - toText (MimaAddress w) = toHex 5 w +addrToDec :: MimaAddress -> T.Text +addrToDec (MimaAddress a) = toDec 7 a + +addrToHex :: MimaAddress -> T.Text +addrToHex (MimaAddress a) = toHex 5 a + +addrToHexDec :: MimaAddress -> T.Text +addrToHexDec ma = addrToHex ma <> " (" <> addrToDec ma <> ")" instance Show MimaAddress where - show ma = T.unpack $ "MimaAddress 0x" <> toText ma + show ma = T.unpack $ "MimaAddress 0x" <> addrToHex ma instance Word32Based MimaAddress where fromWord32 w = MimaAddress $ w .&. 0x000FFFFF @@ -140,5 +168,5 @@ instance Enum MimaAddress where ++ ") is out of bounds " ++ show (lower, upper) fromEnum = fromEnum . toWord32 -addressToWord :: MimaAddress -> MimaWord -addressToWord = fromWord32 . toWord32 +addrToWord :: MimaAddress -> MimaWord +addrToWord = fromWord32 . toWord32