Review fixes

cardano-api/src/Cardano/Api/Typed.hs

@@ -406,6 +406,8 @@ module Cardano.Api.Typed (
     secondsToNominalDiffTime,
 
     -- Testing purposes
+    AssetsBundle(..),
+    AssetIdBundle(..),
     flatten,
     unflatten
   ) where

cardano-api/src/Cardano/Api/Value.hs

@@ -36,6 +36,10 @@ module Cardano.Api.Value
     -- * Internal conversion functions
   , toShelleyLovelace
 
+    -- * Intermediate Value representation
+  , AssetsBundle(..)
+  , AssetIdBundle(..)
+
     -- * Exported for testing purposes
   , flatten
   , unflatten
@@ -45,9 +49,8 @@ import           Prelude
 
 import           Data.Aeson hiding (Value)
 import qualified Data.Aeson as Aeson
-import           Data.Aeson.Types (Parser)
+import           Data.Aeson.Types (Parser, toJSONKeyText)
 import           Data.ByteString (ByteString)
-import           Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import qualified Data.Map.Merge.Strict as Map
 import           Data.Map.Strict (Map)
@@ -103,10 +106,9 @@ lovelaceToQuantity (Lovelace x) = Quantity x
 quantityToLovelace :: Quantity -> Lovelace
 quantityToLovelace (Quantity x) = Lovelace x
 
-data PolicyId = PolicyId ScriptHash
-              | AdaPolicyId
+newtype PolicyId = PolicyId ScriptHash
   deriving stock (Show)
-  deriving (Eq, Ord)
+  deriving newtype (Eq, Ord, IsString)
 
 newtype AssetName = AssetName ByteString
   deriving stock (Show)
@@ -129,123 +131,98 @@ instance Semigroup Value where
 instance Monoid Value where
   mempty = Value Map.empty
 
+-- | Intermediate representation used in the JSON parsing/rendering of 'Value'
+newtype AssetsBundle = AssetsBundle [AssetIdBundle]
+                       deriving (Eq, Ord, Show)
+
+data AssetIdBundle = AssetIdBundle PolicyId (Map AssetName Quantity)
+                   | AdaAsset Quantity
+                   deriving (Eq, Ord, Show)
+
+instance ToJSON AssetsBundle where
+  toJSON (AssetsBundle bundles) = object $ map toPair bundles
+    where
+     toPair :: AssetIdBundle -> (Text, Aeson.Value)
+     toPair (AdaAsset q) = ("lovelace", toJSON q)
+     toPair (AssetIdBundle pid assets) = (renderPolicyId pid, toJSON assets)
+
+     renderPolicyId :: PolicyId -> Text
+     renderPolicyId (PolicyId sh) = Text.decodeUtf8 (serialiseToRawBytesHex sh)
+
+instance ToJSON Quantity where
+  toJSON (Quantity q) = toJSON q
+
+instance FromJSON Quantity where
+  parseJSON = withScientific "MultiAssetQuantity" $ \sci ->
+    case Scientific.floatingOrInteger sci :: Either Double Integer of
+      Left  d -> fail $ "Expected an integer but got: " <> show d
+      Right n -> return $ Quantity n
+
+instance ToJSON AssetName where
+  toJSON (AssetName an) = Aeson.String $ Text.decodeUtf8 an
+
+instance FromJSON AssetName where
+  parseJSON = withText "MultiAssetName"
+                $ \text -> return . AssetName $ Text.encodeUtf8 text
+
+instance ToJSONKey AssetName where
+  toJSONKey = toJSONKeyText
+                $ \(AssetName asset) -> Text.decodeUtf8 asset
+
+instance FromJSONKey AssetName where
+  fromJSONKey = FromJSONKeyText
+                  $ \assetName -> AssetName $ Text.encodeUtf8 assetName
+
+instance FromJSON AssetsBundle where
+  parseJSON = withObject "AssetsBundle" $ \obj ->
+                AssetsBundle <$> HashMap.foldlWithKey' folder (return []) obj
+   where
+     folder
+       :: Parser [AssetIdBundle]
+       -> Text
+       -> Aeson.Value
+       -> Parser [AssetIdBundle]
+     folder acc pid asset = do
+       accum <- acc
+       assetIdBundle <- parsePid pid asset
+       return $ assetIdBundle : accum
+
+     parsePid :: Text -> Aeson.Value -> Parser AssetIdBundle
+     parsePid pid q =
+       case pid of
+         "lovelace" ->
+           AdaAsset <$> parseJSON q
+         other ->
+           let pIdBS = Text.encodeUtf8 other
+           in case deserialiseFromRawBytesHex AsScriptHash pIdBS of
+                Just sHash -> AssetIdBundle (PolicyId sHash) <$> (parseJSON q)
+                Nothing -> fail $ "Failure when deserialising PolicyId: "
+                                <> Text.unpack pid
+
 instance ToJSON Value where
-  toJSON = render . unflatten
+  toJSON = toJSON . unflatten
 
-unflatten :: Value-> Map PolicyId (Map AssetName Quantity)
-unflatten (Value flatMap) = Map.foldlWithKey folder Map.empty flatMap
+unflatten :: Value -> AssetsBundle
+unflatten (Value flatMap) = AssetsBundle $ Map.foldlWithKey folder [] flatMap
  where
   folder
-    :: Map PolicyId (Map AssetName Quantity)
+    :: [AssetIdBundle]
     -> AssetId
     -> Quantity
-    -> Map PolicyId (Map AssetName Quantity)
-  folder acc (AssetId pid aName) q =
-    Map.insertWith (<>) pid (Map.singleton aName q) acc
-  folder acc AdaAssetId q =
-    Map.insertWith (<>) AdaPolicyId (Map.singleton "lovelace" q) acc
-
-render :: Map PolicyId (Map AssetName Quantity) -> Aeson.Value
-render flatMap = Aeson.Object $ Map.foldlWithKey folder HashMap.empty flatMap
- where
-  folder
-    :: HashMap Text Aeson.Value
-    -> PolicyId
-    -> Map AssetName Quantity
-    -> HashMap Text Aeson.Value
-  folder acc (PolicyId sh) nestedMap =
-    HashMap.insertWith
-      objectCombine
-      (Text.decodeUtf8 (serialiseToRawBytesHex sh))
-      (mapToValue nestedMap)
-      acc
-
-  folder acc AdaPolicyId nestedMap =
-    case Map.lookup "lovelace" nestedMap of
-      Just (Quantity n) ->
-        HashMap.insertWith numberCombine "lovelace" (Aeson.Number $ fromInteger n) acc
-      Nothing -> error $ "Expected \"lovelace\" key in: " <> show nestedMap
-
-  mapToValue :: Map AssetName Quantity -> Aeson.Value
-  mapToValue m =
-    Aeson.Object $
-      Map.foldlWithKey
-      (\acc (AssetName n) (Quantity a) ->
-        HashMap.insertWith numberCombine (Text.decodeUtf8 n) (Aeson.Number $ fromInteger a) acc)
-      HashMap.empty
-      m
-
-  objectCombine :: Aeson.Value -> Aeson.Value -> Aeson.Value
-  objectCombine (Aeson.Object hm1) (Aeson.Object hm2) =
-    Aeson.Object (HashMap.unionWith numberCombine hm1 hm2)
-  objectCombine v1 v2 = error $ "Expected two aeson objects but got: "
-                              <> show v1 <>" and " <> show v2
-
-  numberCombine :: Aeson.Value -> Aeson.Value -> Aeson.Value
-  numberCombine (Aeson.Number sci1) (Aeson.Number sci2) = Aeson.Number (sci1 + sci2)
-  numberCombine v1 v2 = error $ "Expected two aeson numbers but got: "
-                              <> show v1 <>" and " <> show v2
+    -> [AssetIdBundle]
+  folder acc (AssetId pid aName) q = AssetIdBundle pid (Map.singleton aName q) : acc
+  folder acc AdaAssetId q = AdaAsset q : acc
 
 instance FromJSON Value where
-  parseJSON jv = flatten <$> parseMA jv
-
-parseMA :: Aeson.Value -> Parser (Map PolicyId (Map AssetName Quantity))
-parseMA =
-  withObject "MultiAssetValue"
-    $ \obj -> HashMap.foldlWithKey' folder (return Map.empty) obj
- where
-  folder
-    :: Parser (Map PolicyId (Map AssetName Quantity))
-    -> Text
-    -> Aeson.Value
-    -> Parser (Map PolicyId (Map AssetName Quantity))
-  folder acc pidText assetNameandQ = do
-    accum <- acc
-    pid <- parsePid pidText
-    aNameQuanMap <- toAssetQuantityMap assetNameandQ
-    return $ Map.insertWith (<>) pid aNameQuanMap accum
-
-  parsePid :: Text -> Parser PolicyId
-  parsePid pid =
-    case pid of
-      "lovelace" -> return AdaPolicyId
-      other -> let pIdBS = Text.encodeUtf8 other
-               in case deserialiseFromRawBytesHex AsScriptHash pIdBS of
-                    Just sHash -> return $ PolicyId sHash
-                    Nothing -> fail $ "Failure when deserialising PolicyId: " <> Text.unpack pid
-
-  toAssetQuantityMap :: Aeson.Value -> Parser (Map AssetName Quantity)
-  toAssetQuantityMap (Aeson.Object hm') =
-    HashMap.foldlWithKey' assetQuantityFolder (return Map.empty) hm'
-  toAssetQuantityMap ll@(Aeson.Number _) =
-    sequenceA $ Map.singleton (AssetName "lovelace") (convNumber ll)
-  toAssetQuantityMap v = fail $ "Expected Aeson Object but got: " <> show v
-
-  assetQuantityFolder
-    :: Parser (Map AssetName Quantity)
-    -> Text -> Aeson.Value -> Parser (Map AssetName Quantity)
-  assetQuantityFolder acc assetName quantity = do
-    accum <- acc
-    q <- convNumber quantity
-    return $ Map.insertWith (<>) (AssetName $ Text.encodeUtf8 assetName) q accum
-
-  convNumber :: Aeson.Value -> Parser Quantity
-  convNumber = withScientific "MultiAssetValue" $ \sci ->
-    case Scientific.floatingOrInteger sci :: Either Double Integer of
-      Left  d -> fail $ "Expected an integer but got: " <> show d
-      Right n -> return $ Quantity n
+  parseJSON jv = flatten <$> parseJSON jv
 
-flatten :: Map PolicyId (Map AssetName Quantity) -> Value
-flatten = Map.foldlWithKey folder (Value Map.empty)
+flatten :: AssetsBundle -> Value
+flatten (AssetsBundle bundles) = foldl folder (Value Map.empty) bundles
  where
-  folder :: Value -> PolicyId -> Map AssetName Quantity -> Value
-  folder acc pid aQmap = acc <> Value (Map.mapKeys (createAssetId pid) aQmap)
-
-  createAssetId :: PolicyId -> AssetName -> AssetId
-  createAssetId pid an@(AssetName bs) =
-    case Text.decodeUtf8 bs of
-      "lovelace" -> AdaAssetId
-      _ -> AssetId pid an
+  folder :: Value -> AssetIdBundle -> Value
+  folder acc (AssetIdBundle pid assetNameQuantityMap) =
+   acc <> Value (Map.mapKeysWith (<>) (\aname -> AssetId pid aname) assetNameQuantityMap)
+  folder acc (AdaAsset q) = acc <> Value (Map.singleton AdaAssetId q)
 
 {-# NOINLINE mergeAssetMaps #-} -- as per advice in Data.Map.Merge docs
 mergeAssetMaps :: Map AssetId Quantity

cardano-api/test/Test/Cardano/Api/Typed/Gen.hs

@@ -1,8 +1,9 @@
 module Test.Cardano.Api.Typed.Gen
   ( genAddressByron
   , genAddressShelley
+  , genAssetsBundle
+  , genAssetIdBundleValue
   , genByronKeyWitness
-  , genIntermedValue
   , genRequiredSig
   , genMofNRequiredSig
   , genMultiSigScript
@@ -170,11 +171,16 @@ genValue =
   valueFromList <$> Gen.list (Range.constant 0 10) ((,)
                 <$> genAssetId <*> genQuantity)
 
-genIntermedValue :: Gen (Map PolicyId (Map AssetName Quantity))
-genIntermedValue = Gen.map (Range.constant 0 10) ((,) <$> genPolicyId <*> genAssetNameQuantity)
- where
-  genAssetNameQuantity :: Gen (Map AssetName Quantity)
-  genAssetNameQuantity = Gen.map (Range.constant 1 10) ((,) <$> genAssetName <*> genQuantity)
+genAssetsBundle :: Gen AssetsBundle
+genAssetsBundle = AssetsBundle <$> Gen.list (Range.constant 1 10) genAssetIdBundleValue
+
+genAssetIdBundleValue :: Gen AssetIdBundle
+genAssetIdBundleValue =
+  Gen.choice [ AssetIdBundle
+                 <$> genPolicyId
+                 <*> Gen.map (Range.singleton 1) ((,) <$> genAssetName <*> genQuantity)
+             , AdaAsset <$> genQuantity
+             ]
 
 genAllRequiredSig :: Gen (MultiSigScript ShelleyEra)
 genAllRequiredSig =

cardano-api/test/Test/Cardano/Api/Typed/Value.hs

@@ -26,11 +26,6 @@ prop_roundtrip_Value_unflatten_flatten =
   property $ do v <- forAll genValue
                 flatten (unflatten v) === v
 
-prop_roundtrip_Value_flatten_unflatten :: Property
-prop_roundtrip_Value_flatten_unflatten =
-  property $ do v <- forAll genIntermedValue
-                unflatten (flatten v) === v
-
 -- -----------------------------------------------------------------------------
 
 tests :: TestTree