Change low-level data types

This commit reorganizes and restructures the low level data types,
like the MimaWord, in preparation for implementing the new MiMa
specification.

src/Mima/Word.hs

@@ -1,33 +1,44 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module Mima.Word
-  (
+  ( topBit
-  -- * MiMa-Word
+  -- * 24-bit value
-    MimaWord
+  , MimaWord
   -- ** Formatting
-  , wordToDec
   , wordToHex
+  , wordToDec
   , wordToHexDec
   -- ** Converting
   , bytesToWord
   , wordToBytes
   , boolToWord
-  -- ** Querying
+  -- ** Properties
-  , wordSize
+  , getSmallOpcode
-  , topBit
+  , getLargeOpcode
-  , upperOpcode
+  , getAddress
-  , lowerOpcode
+  , getLongValue
-  , address
+  , getShortValue
-  -- ** Adding
+  -- ** Operations
   , addWords
-  -- * MiMa-Addresses
+  -- * 20-bit value
+  , LongValue
   , MimaAddress
   -- ** Formatting
-  , addrToDec
+  , longValueToHex
-  , addrToHex
+  , longValueToDec
-  , addrToHexDec
+  , longValueToHexDec
   -- ** Converting
-  , addrToWord
+  , bytesToLongValue
+  , longValueToBytes
+  , longValueToWord
+  -- * 16-bit value
+  , ShortValue
+  -- ** Formatting
+  , shortValueToHex
+  , shortValueToDec
+  , shortValueToHexDec
+  -- ** Converting
+  , signedShortValueToWord
   ) where
 
 import           Data.Bits
@@ -36,67 +47,107 @@ import           Data.Word
 
 import           Mima.Util
 
+{- Type classes and instances for free! -}
+-- Get them now while they're hot!
+
+-- This typeclass is for automatic bit twiddling and enumification for
+-- 'Word32' based types.
 class Word32Based t where
+  usedBits :: t -> Int
   fromWord32 :: Word32 -> t
   toWord32 :: t -> Word32
 
--- The MiMa's words are 24 bits long. The smallest word they fit in is
+topBit :: (Word32Based t) => t -> Bool
--- 'Word32'.
+topBit t = testBit (toWord32 t) (usedBits t - 1)
 
--- TODO Maybe store in the upper 24 bits of a signed type?
+-- Required to make the compiler shut up (see
+-- https://stackoverflow.com/a/17866970)
+newtype WB t = WB { unWB :: t}
 
-newtype MimaWord = MimaWord Word32
+instance (Show t) => Show (WB t) where
-  deriving (Eq)
+  show = show . unWB
 
-wordSize :: Int
+-- Kinda obvious, isn't it? :P
-wordSize = 24
+instance (Word32Based t) => Word32Based (WB t) where
+  usedBits = usedBits . unWB
+  fromWord32 = WB . fromWord32
+  toWord32 = toWord32 . unWB
 
-wordToDec :: MimaWord -> T.Text
+instance (Word32Based t) => Eq (WB t) where
-wordToDec (MimaWord w) = toDec 8 w
+  w1 == w2 = toWord32 (unWB w1) == toWord32 (unWB w2)
 
-wordToHex :: MimaWord -> T.Text
+instance (Word32Based t) => Bits (WB t) where
-wordToHex (MimaWord w) = toHex 6 w
+  t1 .&.   t2 = fromWord32 $ toWord32 t1 .&.   toWord32 t2
-
+  t1 .|.   t2 = fromWord32 $ toWord32 t1 .|.   toWord32 t2
-wordToHexDec :: MimaWord -> T.Text
+  t1 `xor` t2 = fromWord32 $ toWord32 t1 `xor` toWord32 t2
-wordToHexDec mw = wordToHex mw <> " (" <> wordToDec mw <> ")"
-
-instance Show MimaWord where
-  show mw = T.unpack $ "MimaWord 0x" <> wordToHex mw
-
-instance Word32Based MimaWord where
-  fromWord32 w = MimaWord $ w .&. 0x00FFFFFF
-  toWord32 (MimaWord w) = w
-
-instance Bits MimaWord where
-  mw1 .&.   mw2 = fromWord32 $ toWord32 mw1 .&.   toWord32 mw2
-  mw1 .|.   mw2 = fromWord32 $ toWord32 mw1 .|.   toWord32 mw2
-  mw1 `xor` mw2 = fromWord32 $ toWord32 mw1 `xor` toWord32 mw2
   complement = fromWord32 . complement . toWord32
 
-  shiftR mw i = fromWord32 $
+  shiftL t i = fromWord32 $ shiftL (toWord32 t) i
-    let rightShifted = shiftR (toWord32 mw) i
+  shiftR t i = fromWord32 $
-        leftOver = max 0 (wordSize - i)
+    let rightShifted = shiftR (toWord32 t) i
-    in  if topBit mw
+        leftOver = max 0 (usedBits t - i)
-        then shiftL 0xFFFFFFFF leftOver .|. rightShifted
+    in  if topBit t
+        then shiftL (complement zeroBits) leftOver .|. rightShifted
         else rightShifted
 
-  shiftL mw i = fromWord32 $ shiftL (toWord32 mw) i
+  rotateL t i = rotateR t (usedBits t - i)
-
+  rotateR t i =
-  rotateR mw i =
+    let i' = i `mod` usedBits t
-    let i' = i `mod` wordSize
+        w  = toWord32 t
-        w        = toWord32 mw
+    in  fromWord32 $ shiftR w i' .|. shiftL w (usedBits t - i')
-    in  fromWord32 $ shiftR w i' .|. shiftL w (wordSize - i')
-
-  rotateL mw i = rotateR mw (wordSize - i)
 
   zeroBits = fromWord32 zeroBits
   bit = fromWord32 . bit
-  testBit mw i = testBit (toWord32 mw) i
+  testBit t = testBit (toWord32 t)
-  bitSize = const wordSize
+  bitSize = usedBits
-  bitSizeMaybe = const (Just wordSize)
+  bitSizeMaybe = Just . usedBits
   isSigned = const True
   popCount = popCount . toWord32
 
+instance (Word32Based t) => Bounded (WB t) where
+  minBound = fromWord32 zeroBits
+  maxBound = fromWord32 (complement zeroBits)
+
+instance (Word32Based t) => Enum (WB t) where
+  toEnum i =
+    let lower = fromEnum $ toWord32 (minBound :: MimaAddress)
+        upper = fromEnum $ toWord32 (maxBound :: MimaAddress)
+    in  if lower <= i && i <= upper
+        then fromWord32 $ toEnum i
+        else error $ "Enum.toEnum: tag (" ++ show i
+             ++ ") is out of bounds " ++ show (lower, upper)
+
+  fromEnum = fromEnum . toWord32
+
+  -- See 'Enum' laws for types with a 'Bounded' instance
+  enumFrom     x   = enumFromTo     x maxBound
+  enumFromThen x y = enumFromThenTo x y bound
+    where
+      bound | fromEnum y >= fromEnum x = maxBound
+            | otherwise                = minBound
+
+{- The types -}
+
+type MimaWord = WB MimaWord_
+newtype MimaWord_ = MimaWord_ Word32
+
+instance Word32Based MimaWord_ where
+  usedBits _ = 24
+  fromWord32 w = MimaWord_ $ w .&. 0xFFFFFF
+  toWord32 (MimaWord_ w) = w
+
+instance Show MimaWord_ where
+  show mw = T.unpack $ "MimaWord_ 0x" <> toHex 6 (toWord32 mw)
+
+wordToHex :: MimaWord -> T.Text
+wordToHex = toHex 6 . toWord32
+
+wordToDec :: MimaWord -> T.Text
+wordToDec = toDec 8 . toWord32
+
+wordToHexDec :: MimaWord -> T.Text
+wordToHexDec mw = wordToHex mw <> " (" <> wordToDec mw <> ")"
+
 bytesToWord :: Word8 -> Word8 -> Word8 -> MimaWord
 bytesToWord w1 w2 w3 =
   let (w1', w2', w3') = (fromIntegral w1, fromIntegral w2, fromIntegral w3)
@@ -116,57 +167,75 @@ boolToWord :: Bool -> MimaWord
 boolToWord False = zeroBits
 boolToWord True = complement zeroBits
 
-topBit :: MimaWord -> Bool
+getSmallOpcode :: MimaWord -> Word32
-topBit mw = testBit (toWord32 mw) (wordSize - 1)
+getSmallOpcode mw = shiftR (toWord32 mw) 20 .&. 0xF
 
-upperOpcode :: MimaWord -> Word32
+getLargeOpcode :: MimaWord -> Word32
-upperOpcode mw = shiftR (toWord32 mw) 20 .&. 0xF
+getLargeOpcode mw = shiftR (toWord32 mw) 16 .&. 0xF
 
-lowerOpcode :: MimaWord -> Word32
+getAddress :: MimaWord -> MimaAddress
-lowerOpcode mw = shiftR (toWord32 mw) 16 .&. 0xF
+getAddress = getLongValue
 
-address :: MimaWord -> MimaAddress
+getLongValue :: MimaWord -> LongValue
-address = fromWord32 . toWord32
+getLongValue = fromWord32 . toWord32
+
+getShortValue :: MimaWord -> ShortValue
+getShortValue = fromWord32 . toWord32
 
 addWords :: MimaWord -> MimaWord -> MimaWord
-addWords mw1 mw2 = fromWord32 $ toWord32 mw1 + toWord32 mw2
+addWords w1 w2 = fromWord32 $ toWord32 w1 + toWord32 w2
 
--- The MiMa's addresses are 20 bits long. The smallest word they fit
+type MimaAddress = LongValue
--- in is 'Word32'.
+type LongValue = WB LongValue_
+newtype LongValue_ = LongValue_ Word32
 
-newtype MimaAddress = MimaAddress Word32
+instance Word32Based LongValue_ where
-  deriving (Eq, Ord)
+  usedBits _ = 20
+  fromWord32 w = LongValue_ $ w .&. 0xFFFFF
+  toWord32 (LongValue_ w) = w
 
-addrToDec :: MimaAddress -> T.Text
+instance Show LongValue_ where
-addrToDec (MimaAddress a) = toDec 7 a
+  show lv = T.unpack $ "LongValue_ 0x" <> toHex 5 (toWord32 lv)
 
-addrToHex :: MimaAddress -> T.Text
+longValueToHex :: MimaWord -> T.Text
-addrToHex (MimaAddress a) = toHex 5 a
+longValueToHex = toHex 5 . toWord32
 
-addrToHexDec :: MimaAddress -> T.Text
+longValueToDec :: MimaWord -> T.Text
-addrToHexDec ma = addrToHex ma <> " (" <> addrToDec ma <> ")"
+longValueToDec = toDec 7 . toWord32
 
-instance Show MimaAddress where
+longValueToHexDec :: MimaWord -> T.Text
-  show ma = T.unpack $ "MimaAddress 0x" <> addrToHex ma
+longValueToHexDec mw = longValueToHex mw <> " (" <> longValueToDec mw <> ")"
 
-instance Word32Based MimaAddress where
+bytesToLongValue :: Word8 -> Word8 -> Word8 -> LongValue
-  fromWord32 w = MimaAddress $ w .&. 0x000FFFFF
+bytesToLongValue w1 w2 w3 = getAddress $ bytesToWord w1 w2 w3
-  toWord32 (MimaAddress w) = w
 
-instance Bounded MimaAddress where
+longValueToBytes :: LongValue -> (Word8, Word8, Word8)
-  minBound = fromWord32 0x00000
+longValueToBytes = wordToBytes . longValueToWord
-  maxBound = fromWord32 0xFFFFF
 
--- TODO satisfy enum laws with regards to bounded instance
+longValueToWord :: LongValue -> MimaWord
-instance Enum MimaAddress where
+longValueToWord = fromWord32 . toWord32
-  toEnum i =
-    let lower = fromEnum $ toWord32 (minBound :: MimaAddress)
-        upper = fromEnum $ toWord32 (maxBound :: MimaAddress)
-    in  if lower <= i && i <= upper
-        then fromWord32 $ toEnum i
-        else error $ "Enum.toEnum{MimaAddress}: tag (" ++ show i
-                     ++ ") is out of bounds " ++ show (lower, upper)
-  fromEnum = fromEnum . toWord32
 
-addrToWord :: MimaAddress -> MimaWord
+type ShortValue = WB ShortValue_
-addrToWord = fromWord32 . toWord32
+newtype ShortValue_ = ShortValue_ Word32
+
+instance Word32Based ShortValue_ where
+  usedBits _ = 16
+  fromWord32 w = ShortValue_ $ w .&. 0xFFFF
+  toWord32 (ShortValue_ w) = w
+
+instance Show ShortValue_ where
+  show lv = T.unpack $ "ShortValue_ 0x" <> toHex 4 (toWord32 lv)
+
+shortValueToHex :: MimaWord -> T.Text
+shortValueToHex = toHex 4 . toWord32
+
+shortValueToDec :: MimaWord -> T.Text
+shortValueToDec = toDec 5 . toWord32
+
+shortValueToHexDec :: MimaWord -> T.Text
+shortValueToHexDec mw = shortValueToHex mw <> " (" <> shortValueToDec mw <> ")"
+
+signedShortValueToWord :: ShortValue -> MimaWord
+signedShortValueToWord sv
+  | topBit sv = fromWord32 $ 0xFFFF0000 .|. toWord32 sv
+  | otherwise = fromWord32 $ toWord32 sv