diff --git a/src/Mima/Vm/MetaFileParser.hs b/src/Mima/Vm/MetaFileParser.hs index d9e7cd4..f120c3c 100644 --- a/src/Mima/Vm/MetaFileParser.hs +++ b/src/Mima/Vm/MetaFileParser.hs @@ -3,76 +3,81 @@ module Mima.Vm.MetaFileParser ( Metadata(..) - , GlobalData - , LocalData + , AddressRange(..) + , Range(..) ) where import Control.Applicative +import Control.Monad import Data.Aeson import Data.Aeson.Types -import qualified Data.HashMap.Strict as HM -import qualified Data.Map.Strict as Map -import qualified Data.Text as T -import Data.Traversable -import Numeric -import Text.ParserCombinators.ReadP +import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as Map +import qualified Data.Text as T import Mima.Format import Mima.Vm.Word data Metadata = Metadata - { global :: GlobalData - , local :: LocalData + { global :: Map.Map T.Text Value + , local :: [Range] } deriving Show -type GlobalData = Map.Map T.Text Value -type LocalData = Map.Map MimaAddress (Map.Map T.Text Value) +data AddressRange + = RangeFromTo MimaAddress MimaAddress + | RangeAt MimaAddress + deriving Show + +data Range = Range AddressRange (Map.Map T.Text Value) + deriving Show + +instance FromJSON AddressRange where + parseJSON = withObject "address range" $ \obj -> at obj <|> range obj + where + at obj = RangeAt <$> ((obj .: "at") >>= boundedAddress) + range obj = do + start <- obj .: "start" >>= boundedAddress + stop <- obj .: "stop" >>= boundedAddress + when (start > stop) (fail "start must be <= stop") + return $ RangeFromTo start stop + +instance ToJSON AddressRange where + toJSON = Object . addressRangeToMap + +addressRangeToMap :: AddressRange -> Object +addressRangeToMap (RangeAt addr) = HM.fromList ["at" .= T.unpack (toHex addr)] +addressRangeToMap (RangeFromTo start stop) = HM.fromList + [ "start" .= T.unpack (toHex start) + , "stop" .= T.unpack (toHex stop) + ] + +instance FromJSON Range where + parseJSON value = do + addressRange <- parseJSON value + obj <- parseJSON value :: Parser Object + values <- obj .: "values" + pure $ Range addressRange values + +instance ToJSON Range where + toJSON (Range addressRange value) = Object (addressRangeToMap addressRange <> HM.fromList (Map.toList value)) instance FromJSON Metadata where - parseJSON = withObject "root" $ \obj -> do - globalData <- obj .: "global" - localData <- parseLocalData =<< obj .: "local" - return $ Metadata globalData localData + parseJSON = withObject "metadata" $ \obj -> + Metadata <$> obj .: "global" <*> obj .: "local" instance ToJSON Metadata where toJSON Metadata{local, global} = object [ "global" .= toJSON global - , "local" .= toJSON (localDataToJson local) + , "local" .= toJSON local ] -parseLocalData :: Value -> Parser LocalData -parseLocalData = withObject "local" $ \obj -> do - v <- for (HM.toList obj) unpackInner - return $ Map.fromList (concat v) - where - unpackInner (key, nestedValue) = do - (start, end) <- readMimaAddress (T.unpack key) - innerValues <- parseJSON nestedValue - return $ zip [start..end] (repeat innerValues) - -readMimaAddress :: String -> Parser (MimaAddress, MimaAddress) -readMimaAddress input = case readP_to_S readFromHex input of - [(addresses, [])] -> pure addresses - xs -> fail $ "'" ++ input ++ "' is no address, " ++ show xs - -readFromHex :: ReadP (MimaAddress,MimaAddress) -readFromHex = (range <|> single) <* eof - where - range = (,) <$> (boundedAddress <* char '-') <*> boundedAddress - single = (\x -> (x, x)) <$> boundedAddress - -boundedAddress :: ReadP MimaAddress -boundedAddress = do - value <- readS_to_P readHex :: ReadP Integer - if value > maxVal || value < minVal then - fail $ T.unpack $ "Value '" <> toHex value <> "' out of bounds for an address." - else - pure $ fromIntegral value +boundedAddress :: Value -> Parser MimaAddress +boundedAddress value = do + n <- parseJSON value :: Parser Integer + unless (n >= minVal && n <= maxVal) $ + fail $ T.unpack $ + "Value '" <> toHex n <> "' out of bounds for an address." + pure $ fromIntegral n where maxVal = fromIntegral (maxBound :: MimaAddress) minVal = fromIntegral (minBound :: MimaAddress) - -localDataToJson :: LocalData -> Value -localDataToJson outerMap = object $ map formatInnerEntry (Map.toList outerMap) - where - formatInnerEntry (address, innerMap) = fixWidthHex 5 (toHex address) .= toJSON innerMap