wip

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

@@ -362,4 +362,10 @@ translateValue :: Era era => Coin -> Value era
 translateValue = Val.inject
 
 translateCompactValue :: Era era => CompactForm Coin -> CompactForm (Value era)
-translateCompactValue = toCompact . translateValue . fromCompact
+translateCompactValue = assume . toCompact . translateValue . fromCompact
+  where
+  assume Nothing = error "impossible error: compact coin is out of range"
+  assume (Just x) = x
+
+
+

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

@@ -5,6 +5,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -19,23 +21,41 @@ module Cardano.Ledger.Mary.Value
   )
 where
 
+import Data.Word (Word64)
 import Cardano.Binary
   ( FromCBOR,
     ToCBOR,
-    encodeListLen,
     fromCBOR,
     toCBOR,
+    peekTokenType,
+    decodeInt64,
+    decodeWord64,
+    TokenType (..),
   )
 import Cardano.Ledger.Compactible (Compactible (..))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era
 import Cardano.Ledger.Torsor (Torsor (..))
-import Cardano.Ledger.Val (Val (..))
+import Cardano.Ledger.Val
+  ( Val (..)
+  , DecodeNonNegative (..)
+  , DecodeMint (..)
+  , EncodeMint (..)
+  )
 import Control.DeepSeq (NFData (..))
 import Control.Monad (guard)
 import Data.Array (Array)
+import qualified Cardano.Crypto.Hash.Class as Hash
 import Data.Array.IArray (array)
 import Data.ByteString (ByteString)
+import Data.Coders
+   ( decode
+   , Decode (..)
+   , (<!)
+   , encode
+   , Encode (..)
+   , (!>)
+   )
 import Data.CannonicalMaps
   ( cannonicalMap,
     cannonicalMapUnion,
@@ -48,19 +68,21 @@ import Data.Map.Internal
     link2,
     splitLookup,
   )
+import Data.Map (Map)
 import Data.Map.Strict (assocs)
 import qualified Data.Map.Strict as Map
+import qualified Data.Map.Merge.Strict as Map
 import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Typeable (Typeable)
-import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
 import Shelley.Spec.Ledger.Coin (Coin (..), integerToWord64)
-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 Shelley.Spec.Ledger.Serialization (decodeMap, encodeMap)
 
 -- | Asset Name
 newtype AssetName = AssetName {assetName :: ByteString}
@@ -147,24 +169,98 @@ 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
 
+decodeInteger :: Decoder s Integer
+decodeInteger = fromIntegral <$> decodeInt64
+
+decodeValue ::
+ ( Typeable (Core.Script era),
+  Era era
+  ) => Decoder s (Value era)
+decodeValue = do
+  tt <- peekTokenType
+  case tt of
+    TypeUInt -> inject . Coin <$> decodeInteger
+    TypeNInt -> inject . Coin <$> decodeInteger
+    TypeListLen -> decodeValuePair decodeInteger
+    TypeListLen64 -> decodeValuePair decodeInteger
+    TypeListLenIndef -> decodeValuePair decodeInteger
+    _ -> fail $ "Value: expected array or int"
+
+decodeValuePair ::
+ ( Typeable (Core.Script era),
+  Era era
+  ) => (forall t. Decoder t Integer) -> Decoder s (Value era)
+decodeValuePair decodeAmount = decode $
+  RecD Value
+  <! D decodeAmount
+  <! D (decodeMultiAssetMaps decodeAmount)
+
+encodeMultiAssetMaps ::
+ ( Typeable (Core.Script era),
+  Era era
+  ) => Map (PolicyID era) (Map AssetName Integer)
+    -> Encoding
+encodeMultiAssetMaps = encodeMap toCBOR (encodeMap toCBOR toCBOR)
+
+decodeMultiAssetMaps ::
+ ( Typeable (Core.Script era),
+  Era era
+  ) => Decoder s Integer
+   -> Decoder s (Map (PolicyID era) (Map AssetName Integer))
+decodeMultiAssetMaps decodeAmount =
+  prune <$> decodeMap fromCBOR (decodeMap fromCBOR decodeAmount)
+
+decodeNonNegativeInteger :: Decoder s Integer
+decodeNonNegativeInteger = fromIntegral <$> decodeWord64
+
+decodeNonNegativeValue ::
+ ( Typeable (Core.Script era),
+  Era era
+  ) => Decoder s (Value era)
+decodeNonNegativeValue = do
+  tt <- peekTokenType
+  case tt of
+    TypeUInt -> inject . Coin <$> decodeNonNegativeInteger
+    TypeListLen -> decodeValuePair decodeNonNegativeInteger
+    TypeListLen64 -> decodeValuePair decodeNonNegativeInteger
+    TypeListLenIndef -> decodeValuePair decodeNonNegativeInteger
+    _ -> fail $ "Value: expected array or int"
+
 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
+    else
+      encode $
+        Rec Value
+         !> To c
+         !> E encodeMultiAssetMaps 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
+
+instance
+  (Era era, Typeable (Core.Script era)) =>
+  DecodeNonNegative (Value era)
+  where
+  decodeNonNegative = decodeNonNegativeValue
+
+instance
+  (Era era, Typeable (Core.Script era)) =>
+  DecodeMint (Value era)
+  where
+  decodeMint = Value 0 <$> decodeMultiAssetMaps decodeInteger
+
+instance
+  (Era era, Typeable (Core.Script era)) =>
+  EncodeMint (Value era)
+  where
+  encodeMint (Value _ multiasset) = encodeMultiAssetMaps multiasset
 
 -- ========================================================================
 -- Compactible
@@ -173,14 +269,19 @@ instance
 instance Era era => Compactible (Value era) where
   newtype CompactForm (Value era) = CompactValue (CV era)
     deriving (ToCBOR, FromCBOR)
-  toCompact = CompactValue . toCV
+  toCompact x = CompactValue <$> toCV x
   fromCompact (CompactValue x) = fromCV x
 
 instance (Typeable (Core.Script era), Era era) => ToCBOR (CV era) where
   toCBOR = toCBOR . fromCV
 
 instance (Typeable (Core.Script era), Era era) => FromCBOR (CV era) where
-  fromCBOR = toCV <$> fromCBOR
+  fromCBOR = do
+    v <- decodeNonNegativeValue
+    case toCV v of
+      Nothing -> fail
+        "impossible failure: decoded nonnegative value that cannot be compacted"
+      Just x -> pure x
 
 data CV era
   = CV
@@ -193,24 +294,23 @@ data CVPart era
       {-# UNPACK #-} !AssetName
       {-# UNPACK #-} !Word64
 
-toCV :: Value era -> CV era
-toCV v =
+toCV :: Value era -> Maybe (CV era)
+toCV v = do
   let (c, triples) = gettriples v
       policyIDs = Set.fromList $ (\(x, _, _) -> x) <$> triples
       n = length triples - 1
-      arr = array (0, n) (zip [0 .. n] (toCVPart policyIDs <$> triples))
-   in CV (convert c) arr
+  cvParts <- traverse (toCVPart policyIDs) triples
+  let arr = array (0, n) (zip [0 .. n] cvParts)
+  c' <- integerToWord64 c
+  pure $ CV c' arr
   where
     deduplicate xs x = fromMaybe x $ do
       r <- Set.lookupLE x xs
       guard (x == r)
       pure r
     toCVPart policyIdSet (policyId, aname, amount) =
-      CVPart (deduplicate policyIdSet policyId) aname (convert amount)
-    convert x =
-      fromMaybe
-        (error $ "out of bounds : " ++ show x)
-        (integerToWord64 x)
+      CVPart (deduplicate policyIdSet policyId) aname <$>
+        integerToWord64 amount
 
 fromCV :: Era era => CV era -> Value era
 fromCV (CV w vs) = foldr f (inject . Coin . fromIntegral $ w) vs
@@ -287,6 +387,12 @@ insert combine pid aid new (Value cn m1) =
 
 -- ========================================================
 
+-- | Remove 0 assets from a map
+prune :: Map (PolicyID era) (Map AssetName Integer)
+   -> Map (PolicyID era) (Map AssetName Integer)
+prune assets =
+  Map.filter (not . null) $ Map.filter (/=0) <$> assets
+
 -- | 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/impl/src/Cardano/Ledger/ShelleyMA/Rules/Utxow.hs

@@ -22,7 +22,7 @@ import Cardano.Ledger.ShelleyMA.Rules.Utxo ()
 import Cardano.Ledger.ShelleyMA.Scripts ()
 import Cardano.Ledger.ShelleyMA.TxBody ()
 import Cardano.Ledger.Torsor (Torsor (..))
-import Cardano.Ledger.Val (Val)
+import Cardano.Ledger.Val (Val, DecodeNonNegative, DecodeMint)
 import Control.State.Transition.Extended
 import Data.Foldable (Foldable (toList))
 import qualified Data.Map.Strict as Map
@@ -120,6 +120,8 @@ instance
     Typeable ma,
     STS (UTXO (ShelleyMAEra ma c)),
     BaseM (UTXO (ShelleyMAEra ma c)) ~ ShelleyBase,
+    DecodeMint (Core.Value (ShelleyMAEra ma c)),
+    DecodeNonNegative (Core.Value (ShelleyMAEra ma c)),
     Compactible (Core.Value (ShelleyMAEra ma c)),
     Val (Core.Value (ShelleyMAEra ma c)),
     GetPolicies (Core.Value (ShelleyMAEra ma c)) (ShelleyMAEra ma c),

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA/TxBody.hs

@@ -42,7 +42,11 @@ import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era (Era)
 import Cardano.Ledger.ShelleyMA (MaryOrAllegra, ShelleyMAEra)
 import Cardano.Ledger.ShelleyMA.Timelocks (ValidityInterval (..))
-import Cardano.Ledger.Val (Val (..))
+import Cardano.Ledger.Val
+   (Val (..)
+   , DecodeNonNegative
+   , DecodeMint (..)
+   )
 import Control.DeepSeq (NFData (..))
 import Data.Coders
   ( Decode (..),
@@ -88,6 +92,10 @@ type FamsFrom era =
     Typeable era,
     Typeable (Script era),
     Typeable (Core.Metadata era),
+    Show (Value era),
+    Compactible (Value era),
+    DecodeNonNegative (Value era),
+    DecodeMint (Value era),
     FromCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
     FromCBOR (Value era),
     FromCBOR (Annotator (Script era)) -- Arises becaause DCert memoizes its bytes
@@ -96,6 +104,7 @@ type FamsFrom era =
 type FamsTo era =
   ( Era era,
     ToCBOR (Value era),
+    Compactible (Value era),
     ToCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
     ToCBOR (Script era),
     Typeable (Core.Metadata era)
@@ -185,7 +194,7 @@ bodyFields 5 = field (\x tx -> tx {wdrls = x}) From
 bodyFields 6 = field (\x tx -> tx {update = x}) (D (SJust <$> fromCBOR))
 bodyFields 7 = field (\x tx -> tx {mdHash = x}) (D (SJust <$> fromCBOR))
 bodyFields 8 = field (\x tx -> tx {vldt = (vldt tx) {validFrom = x}}) (D (SJust <$> fromCBOR))
-bodyFields 9 = field (\x tx -> tx {forge = x}) From
+bodyFields 9 = field (\x tx -> tx {forge = x}) (D decodeMint)
 bodyFields n = field (\_ t -> t) (Invalid n)
 
 initial :: (Val (Value era)) => TxBodyRaw era

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

@@ -25,9 +25,9 @@ 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.TxBody M) n "transaction_body",
-      -- cddlTest' @(Core.TxBody A) n "transaction_body",
+      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",
       cddlTest' @(Core.Script A) n "native_script",
       cddlTest' @(Core.Metadata M) n "transaction_metadata",

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Compactible.hs

@@ -27,7 +27,7 @@ import Data.Typeable (Typeable)
 
 class Compactible a where
   data CompactForm a :: Type
-  toCompact :: a -> CompactForm a
+  toCompact :: a -> Maybe (CompactForm a)
   fromCompact :: CompactForm a -> a
 
 newtype Compact a = Compact {unCompact :: a}

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs

@@ -11,7 +11,7 @@ import Cardano.Ledger.Core
 import qualified Cardano.Ledger.Crypto as CryptoClass
 import Cardano.Ledger.Era
 import Cardano.Ledger.Torsor (Torsor (..))
-import Cardano.Ledger.Val (Val)
+import Cardano.Ledger.Val (Val, DecodeNonNegative)
 import Shelley.Spec.Ledger.Coin (Coin)
 import Shelley.Spec.Ledger.Hashing (EraIndependentTxBody, HashAnnotated (..))
 
@@ -38,6 +38,7 @@ type ShelleyBased era =
     -- Value constraints
     Val (Value era),
     Compactible (Value era),
+    DecodeNonNegative (Value era),
     ChainData (Value era),
     SerialisableData (Value era),
     SerialisableData (CompactForm (Value era)),