Add support for flags in execution

src/Mima/Flag.hs

@@ -0,0 +1,136 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Mima.Flag
+  ( AddressRange
+  , lowerAddress
+  , upperAddress
+  , range
+  , rangeToAddresses
+  , rangeContains
+  , simplifyRanges
+  , AddressSpec
+  , rangesToSpec
+  , specToRanges
+  , specNull
+  , specContains
+  , Flag(..)
+  , allFlags
+  , flagChar
+  , Flags(..)
+  , rawFlags
+  , flagChecks
+  , impotentChecks
+  ) where
+
+import           Data.List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import           Mima.Word
+
+data AddressRange = AddressRange
+  { lowerAddress :: MimaAddress
+  , upperAddress :: MimaAddress
+  } deriving (Show, Eq, Ord)
+
+range :: MimaAddress -> MimaAddress -> AddressRange
+range a b
+  | a <= b    = AddressRange a b
+  | otherwise = AddressRange b a
+
+rangeToAddresses :: AddressRange -> [MimaAddress]
+rangeToAddresses r = [lowerAddress r..upperAddress r]
+
+rangeContains :: AddressRange -> MimaAddress -> Bool
+rangeContains (AddressRange a b) c = a <= c && c <= b
+
+simplifyRanges :: [AddressRange] -> [AddressRange]
+simplifyRanges = helper . sort
+  where
+    helper :: [AddressRange] -> [AddressRange]
+    helper (r1:r2:rs)
+      | upperAddress r1 >= lowerAddress r2 = helper (merge r1 r2 : rs)
+      | otherwise                          = r1 : helper (r2:rs)
+    helper a = a
+
+    merge :: AddressRange -> AddressRange -> AddressRange
+    merge (AddressRange a1 b1) (AddressRange _ b2) = AddressRange a1 (max b1 b2)
+
+
+newtype AddressSpec = AddressSpec [AddressRange]
+  deriving (Show)
+
+rangesToSpec :: [AddressRange] -> AddressSpec
+rangesToSpec = AddressSpec . simplifyRanges
+
+specToRanges :: AddressSpec -> [AddressRange]
+specToRanges (AddressSpec ranges) = ranges
+
+specNull :: AddressSpec -> Bool
+specNull = null . specToRanges
+
+specContains :: AddressSpec -> MimaAddress -> Bool
+specContains as addr = any (`rangeContains` addr) $ specToRanges as
+
+{- Enough preamble, let's get to the flags -}
+
+data Flag = Breakpoint | Executable | ReadOnly
+  deriving (Show, Eq, Ord)
+
+allFlags :: [Flag]
+allFlags = [Breakpoint, Executable, ReadOnly]
+
+flagChar :: Flag -> Char
+flagChar Breakpoint = 'b'
+flagChar Executable = 'e'
+flagChar ReadOnly   = 'r'
+
+data Flags a = Flags
+  { flagBreakpoint :: a
+  , flagExecutable :: a
+  , flagReadOnly   :: a
+  } deriving (Show)
+
+instance Functor Flags where
+  fmap f Flags{..} = Flags
+    { flagBreakpoint = f flagBreakpoint
+    , flagExecutable = f flagExecutable
+    , flagReadOnly   = f flagReadOnly
+    }
+
+instance Applicative Flags where
+  pure a = Flags a a a
+  f <*> a = Flags
+    { flagBreakpoint = flagBreakpoint f $ flagBreakpoint a
+    , flagExecutable = flagExecutable f $ flagExecutable a
+    , flagReadOnly   = flagReadOnly f   $ flagReadOnly a
+    }
+
+rawFlags :: Flags Flag
+rawFlags = Flags
+  { flagBreakpoint = Breakpoint
+  , flagExecutable = Executable
+  , flagReadOnly   = ReadOnly
+  }
+
+flagChecks :: Map.Map AddressRange (Set.Set Flag) -> Flags (MimaAddress -> Bool)
+flagChecks m =
+  let getAddressSpec :: Flag -> AddressSpec
+      getAddressSpec f = rangesToSpec $ map fst $ filter (Set.member f . snd) $ Map.assocs m
+
+      conditions :: Flags (AddressSpec -> MimaAddress -> Bool)
+      conditions = Flags
+        { flagBreakpoint = specContains
+        , flagExecutable = \as -> if specNull as then const True else specContains as
+        , flagReadOnly = specContains
+        }
+  in  conditions <*> (getAddressSpec <$> rawFlags)
+
+-- | Flag checks that should not alter the behaviour of the MiMa.
+impotentChecks :: Flags (MimaAddress -> Bool)
+impotentChecks = Flags
+  { flagBreakpoint = const False
+  , flagExecutable = const True
+  , flagReadOnly   = const False
+  }