Spice up Metafile format

src/Mima/Vm/MetaFileParser.hs

@@ -3,76 +3,81 @@
 
 module Mima.Vm.MetaFileParser
   ( Metadata(..)
-  , GlobalData
+  , AddressRange(..)
-  , LocalData
+  , 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.HashMap.Strict as HM
-import qualified Data.Map.Strict              as Map
+import qualified Data.Map.Strict     as Map
-import qualified Data.Text                    as T
+import qualified Data.Text           as T
-import           Data.Traversable
-import           Numeric
-import           Text.ParserCombinators.ReadP
 
 import           Mima.Format
 import           Mima.Vm.Word
 
 data Metadata = Metadata
- { global :: GlobalData
+ { global :: Map.Map T.Text Value
- , local  :: LocalData
+ , local  :: [Range]
  } deriving Show
 
-type GlobalData = Map.Map T.Text Value
+data AddressRange
-type LocalData = Map.Map MimaAddress (Map.Map T.Text Value)
+  = 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
+  parseJSON = withObject "metadata" $ \obj ->
-    globalData <- obj .: "global"
+    Metadata <$> obj .: "global" <*> obj .: "local"
-    localData <- parseLocalData =<< obj .: "local"
-    return $ Metadata globalData localData
 
 instance ToJSON Metadata where
   toJSON Metadata{local, global} = object
    [ "global" .= toJSON global
-   , "local" .= toJSON (localDataToJson local)
+   , "local" .= toJSON local
    ]
 
-parseLocalData :: Value -> Parser LocalData
+boundedAddress :: Value -> Parser MimaAddress
-parseLocalData = withObject "local" $ \obj -> do
+boundedAddress value = do
-  v <- for (HM.toList obj) unpackInner
+  n <- parseJSON value :: Parser Integer
-  return $ Map.fromList (concat v)
+  unless (n >= minVal && n <= maxVal) $
-  where
+    fail $ T.unpack $
-    unpackInner (key, nestedValue) = do
+    "Value '" <> toHex n <> "' out of bounds for an address."
-      (start, end) <- readMimaAddress (T.unpack key)
+  pure $ fromIntegral n
-      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
   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