143 lines
3.7 KiB
Haskell
143 lines
3.7 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Mima.Flag
|
|
( AddressRange
|
|
, lowerAddress
|
|
, upperAddress
|
|
, range
|
|
, rangeToAddresses
|
|
, rangeContains
|
|
, simplifyRanges
|
|
, AddressSpec
|
|
, rangesToSpec
|
|
, specToRanges
|
|
, specNull
|
|
, specContains
|
|
, Flag(..)
|
|
, flagChar
|
|
, Flags(..)
|
|
, rawFlags
|
|
, RawFlags
|
|
, FlagSpec
|
|
, getFlagSpec
|
|
, interpretFlagSpec
|
|
, noFlags
|
|
) 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)
|
|
|
|
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
|
|
}
|
|
|
|
type RawFlags = Map.Map AddressRange (Set.Set Char)
|
|
type FlagSpec = Flags AddressSpec
|
|
|
|
getFlagSpec :: RawFlags -> FlagSpec
|
|
getFlagSpec af =
|
|
let isInSet :: Flag -> Set.Set Char -> Bool
|
|
isInSet f s = flagChar f `Set.member` s
|
|
getAddressSpec :: Flag -> AddressSpec
|
|
getAddressSpec f = rangesToSpec $ map fst $ filter (isInSet f . snd) $ Map.assocs af
|
|
in pure getAddressSpec <*> rawFlags
|
|
|
|
interpretFlagSpec :: FlagSpec -> Flags (MimaAddress -> Bool)
|
|
interpretFlagSpec spec =
|
|
let conditions :: Flags (AddressSpec -> MimaAddress -> Bool)
|
|
conditions = Flags
|
|
{ flagBreakpoint = specContains
|
|
, flagExecutable = \as -> if specNull as then const True else specContains as
|
|
, flagReadOnly = specContains
|
|
}
|
|
in conditions <*> spec
|
|
|
|
-- | These checks should behave as if no flags were set at all.
|
|
noFlags :: Flags (MimaAddress -> Bool)
|
|
noFlags = Flags
|
|
{ flagBreakpoint = const False
|
|
, flagExecutable = const True
|
|
, flagReadOnly = const False
|
|
}
|