wip

shelley-ma/impl/src/Cardano/Ledger/Mary/Value.hs

@@ -7,6 +7,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE Rank2Types #-}
 
 module Cardano.Ledger.Mary.Value
   ( PolicyID (..),
@@ -19,42 +21,47 @@ module Cardano.Ledger.Mary.Value
   )
 where
 
+import Data.String (fromString)
+import Cardano.Prelude (cborError, panic)
+import Data.Word (Word64)
 import Cardano.Binary
   ( FromCBOR,
     ToCBOR,
-    encodeListLen,
     fromCBOR,
     toCBOR,
+    peekTokenType,
+    TokenType (..),
+    DecoderError (..),
   )
 import Cardano.Ledger.Compactible (Compactible (..))
 import qualified Cardano.Ledger.Core as Core
+import qualified Data.ByteString.Short as SBS
 import Cardano.Ledger.Era
 import Cardano.Ledger.Torsor (Torsor (..))
 import Cardano.Ledger.Val (Val (..))
 import Control.DeepSeq (NFData (..))
+import qualified Cardano.Ledger.Crypto  as Crypto
+import qualified Cardano.Crypto.Hash.Class as Hash
 import Data.ByteString (ByteString)
 import Data.CannonicalMaps
   ( cannonicalMap,
     cannonicalMapUnion,
     pointWise,
   )
 import Data.Group (Abelian, Group (..))
-import Data.Map.Internal
-  ( Map (..),
-    link,
-    link2,
-    splitLookup,
-  )
+import Data.Map (Map)
 import Data.Map.Strict (assocs)
 import qualified Data.Map.Strict as Map
 import Data.Set (Set)
-import Data.Typeable (Typeable)
+import Data.Typeable (Typeable, Proxy (..))
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
 import Shelley.Spec.Ledger.Coin (Coin (..))
-import Shelley.Spec.Ledger.Scripts (ScriptHash)
-import Shelley.Spec.Ledger.Serialization (decodeRecordNamed)
+import Shelley.Spec.Ledger.Scripts (ScriptHash (..))
 import Prelude hiding (lookup)
+import Cardano.Binary (Decoder)
+import Data.Maybe (fromMaybe)
+import Shelley.Spec.Ledger.Serialization (decodeMap)
 
 -- | Asset ID
 newtype AssetID = AssetID {assetID :: ByteString}
@@ -140,24 +147,77 @@ instance Era era => Val (Value era) where
 -- TODO Probably the actual serialization will be of the formal Coin OR Value type
 -- Maybe better to make this distinction in the TxOut de/serialization
 
+adaAssetName :: AssetID
+adaAssetName = AssetID mempty
+
+adaPolicyId :: forall era. Era era => PolicyID era
+adaPolicyId =  PolicyID . ScriptHash . Hash.UnsafeHash $ SBS.pack bytes
+  where
+  hashlen = fromIntegral $
+     Hash.sizeHash (Proxy :: Proxy (Crypto.ADDRHASH (Crypto era)))
+  ada = [0x0A,0xDA]
+  bytes = if hashlen <= 2
+    then take 2 ada
+    else replicate (hashlen - 2) 0 <> ada
+
+decodeIntegerValue :: Era era => Decoder s (Value era)
+decodeIntegerValue = inject <$> fromCBOR
+
+deleteAsset :: PolicyID era -> AssetID
+   -> Map (PolicyID era) (Map AssetID Integer)
+   -> Map (PolicyID era) (Map AssetID Integer)
+deleteAsset policyId assetName = Map.alter f policyId
+  where
+  f Nothing = Nothing
+  f (Just m) =
+   let map' = Map.delete assetName m
+   in if null map' then Nothing else Just map'
+
+decodeMapValue ::
+ ( Typeable (Core.Script era),
+  Era era
+  ) => Decoder s (Value era)
+decodeMapValue = do
+  maps <- decodeMap fromCBOR (decodeMap fromCBOR fromCBOR)
+  let adaAmount = fromMaybe 0 $
+        Map.lookup adaPolicyId maps >>= Map.lookup adaAssetName
+      nonAda = deleteAsset adaPolicyId adaAssetName maps
+  pure $ Value adaAmount (prune nonAda)
+
+decodeValue ::
+ ( Typeable (Core.Script era),
+  Era era
+  ) => Decoder s (Value era)
+decodeValue = do
+  tt <- peekTokenType
+  case tt of
+    TypeUInt -> decodeIntegerValue
+    TypeNInt -> decodeIntegerValue -- TODO: Separate nongegative and allowed-negative
+    TypeMapLen -> decodeMapValue
+    TypeMapLen64 -> decodeMapValue
+    TypeMapLenIndef -> decodeMapValue
+    _ -> cborError $ DecoderErrorCustom "Value" "expected map or uint"
+
+
+integerToWord64 :: Integer -> Word64
+integerToWord64 x =
+  if (x > fromIntegral (maxBound :: Word64)) || (x < 0)
+  then panic $ fromString $ "cannot cast " <> show x <> " to Word64"
+  else fromIntegral x
+
 instance
   (Era era, Typeable (Core.Script era)) =>
   ToCBOR (Value era)
   where
-  toCBOR (Value c v) =
-    encodeListLen 2
-      <> toCBOR c
-      <> toCBOR v
+  toCBOR (Value c v) = if Map.null v
+    then toCBOR c -- (integerToWord64 c)
+    else toCBOR $ insert' (+) adaPolicyId adaAssetName c v
 
 instance
   (Era era, Typeable (Core.Script era)) =>
   FromCBOR (Value era)
   where
-  fromCBOR = do
-    decodeRecordNamed "Value" (const 2) $ do
-      c <- fromCBOR
-      v <- fromCBOR
-      pure $ Value c v
+  fromCBOR = decodeValue
 
 -- ========================================================================
 -- Compactible
@@ -204,42 +264,28 @@ insert ::
   Integer ->
   Value era ->
   Value era
-insert combine pid aid new (Value cn m1) =
-  case splitLookup pid m1 of
-    (l1, Just m2, l2) ->
-      case splitLookup aid m2 of
-        (v1, Just old, v2) ->
-          if n == 0
-            then
-              let m3 = (link2 v1 v2)
-               in if Map.null m3
-                    then Value cn (link2 l1 l2)
-                    else Value cn (link pid m3 l1 l2)
-            else Value cn (link pid (link aid n v1 v2) l1 l2)
-          where
-            n = combine old new
-        (_, Nothing, _) ->
-          Value
-            cn
-            ( link
-                pid
-                ( if new == 0
-                    then m2
-                    else (Map.insert aid new m2)
-                )
-                l1
-                l2
-            )
-    (l1, Nothing, l2) ->
-      Value
-        cn
-        ( if new == 0
-            then link2 l1 l2
-            else link pid (Map.singleton aid new) l1 l2
-        )
+insert combine pid aid new (Value cn m1) = Value cn $ 
+  insert' combine pid aid new m1
 
 -- ========================================================
 
+-- | Remove 0 assets from a map
+prune :: Map (PolicyID era) (Map AssetID Integer)
+   -> Map (PolicyID era) (Map AssetID Integer)
+prune assets =
+  Map.filter (not . null) $ Map.filter (/=0) <$> assets
+
+insert' ::
+  (Integer -> Integer -> Integer) ->
+     PolicyID era -> AssetID
+   -> Integer
+   -> Map (PolicyID era) (Map AssetID Integer)
+   -> Map (PolicyID era) (Map AssetID Integer)
+insert' f policyId assetName amount assets = prune $
+  Map.unionWith (Map.unionWith f) assets singleton
+  where
+  singleton = Map.singleton policyId $ Map.singleton assetName amount
+
 -- | Display a Value as a String, one token per line
 showValue :: Value era -> String
 showValue v = show c ++ "\n" ++ unlines (map trans ts)

shelley-ma/shelley-ma-test/cddl-files/shelley-ma.cddl

@@ -243,7 +243,7 @@ coin = uint
 ;asset name for ada is empty string
 multiasset<a> = { * policy_id => { * asset_name => a } }
 policy_id = scripthash
-asset_name = text .size (0..32)
+asset_name = bytes .size (0..32)
 
 value = coin / multiasset<uint>
 forge = multiasset<int>

shelley-ma/shelley-ma-test/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/CDDL.hs

@@ -28,7 +28,7 @@ cddlTests :: Int -> TestTree
 cddlTests n = withResource combinedCDDL (const (pure ())) $ \cddl ->
   testGroup "CDDL roundtrip tests" $
     [ cddlTest @(Core.Value A) n "coin"
-    --, cddlTest @(Core.Value M) n "value"
+    , cddlTest @(Core.Value M) n "value"
     -- , cddlTest' @(Core.TxBody M) n "transaction_body"
     -- , cddlTest' @(Core.TxBody A) n "transaction_body"
     , cddlTest' @(Core.Script M) n "native_script"