Clean up metadata

This commit also changes the metadata file format. Documentation coming soon™

src/Mima/Vm/MetaFileParser.hs

@@ -1,83 +0,0 @@
-{-# LANGUAGE NamedFieldPuns    #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Mima.Vm.MetaFileParser
-  ( Metadata(..)
-  , 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           Mima.Format
-import           Mima.Vm.Word
-
-data Metadata = Metadata
- { global :: Map.Map T.Text Value
- , local  :: [Range]
- } deriving Show
-
-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 "metadata" $ \obj ->
-    Metadata <$> obj .: "global" <*> obj .: "local"
-
-instance ToJSON Metadata where
-  toJSON Metadata{local, global} = object
-   [ "global" .= toJSON global
-   , "local" .= toJSON local
-   ]
-
-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)

src/Mima/Vm/Metadata.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Mima.Vm.Metadata
+  ( MetaInfo
+  , Range(..)
+  , getMetaInfo
+  , Metadata(..)
+  ) where
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.Aeson
+import           Data.Aeson.Types
+import qualified Data.Map.Strict     as Map
+import qualified Data.Text           as T
+
+import           Mima.Vm.Word
+
+type MetaInfo = Map.Map T.Text Value
+
+data Range
+  = RangeAt     MetaInfo MimaAddress
+  | RangeFromTo MetaInfo MimaAddress MimaAddress
+  deriving Show
+
+getMetaInfo :: Range -> MetaInfo
+getMetaInfo (RangeAt     info _)   = info
+getMetaInfo (RangeFromTo info _ _) = info
+
+data Metadata = Metadata
+ { mdGlobal :: MetaInfo
+ , mdLocal  :: [Range]
+ } deriving Show
+
+instance Semigroup Metadata where
+  md1 <> md2 =
+    Metadata (mdGlobal md1 <> mdGlobal md2) (mdLocal md1 <> mdLocal md2)
+
+instance Monoid Metadata where
+  mempty = Metadata mempty mempty
+
+boundedAddress :: Parser Value -> Parser MimaAddress
+boundedAddress p = do
+  n <- parseJSON =<< p :: Parser Integer
+  unless (n >= minVal && n <= maxVal) $
+    fail $ "value " ++ show n ++  " out of bounds for an address"
+  pure $ fromIntegral n
+  where
+    maxVal = fromIntegral (maxBound :: MimaAddress)
+    minVal = fromIntegral (minBound :: MimaAddress)
+
+instance FromJSON Range where
+  parseJSON = withObject "range" $ \o -> do
+    info <- parseJSON =<< o .: "info"
+    rangeAt info o <|> rangeFromTo info o
+    where
+      rangeAt info o = RangeAt info <$> boundedAddress (o .: "at")
+      rangeFromTo info o = do
+        start <- boundedAddress (o .: "start")
+        stop <- boundedAddress (o .: "stop")
+        when (start > stop) (fail "start must not be greater than stop")
+        pure $ RangeFromTo info start stop
+
+instance ToJSON Range where
+  toJSON (RangeAt info at) = object
+    [ "at"   .= toJSON (toInteger at)
+    , "info" .= toJSON info
+    ]
+  toJSON (RangeFromTo info start stop) = object
+    [ "start" .= toJSON (toInteger start)
+    , "stop"  .= toJSON (toInteger stop)
+    , "info" .= toJSON info
+    ]
+
+instance FromJSON Metadata where
+  parseJSON = withObject "metadata" $ \obj ->
+    Metadata <$> obj .: "global" <*> obj .: "local"
+
+instance ToJSON Metadata where
+  toJSON md = object
+    [ "global" .= toJSON (mdGlobal md)
+    , "local" .= toJSON (mdLocal md)
+    ]