wip

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

@@ -16,11 +16,11 @@ shadowing warnings for the named field puns when used with a pattern synonym.
 module Cardano.Ledger.Mary.Translation where
 
 import Cardano.Ledger.Allegra (AllegraEra)
-import Cardano.Ledger.Compactible
+import Cardano.Ledger.Compactible (Compactible (..))
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Era hiding (Crypto)
 import Cardano.Ledger.Mary (MaryEra)
-import Cardano.Ledger.Mary.Value
+import Cardano.Ledger.Mary.Value (Value (..))
 import Cardano.Ledger.ShelleyMA.Metadata (Metadata (..), pattern Metadata)
 import Cardano.Ledger.ShelleyMA.Scripts (Timelock)
 import Cardano.Ledger.ShelleyMA.TxBody
@@ -362,4 +362,7 @@ 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,18 +21,18 @@ module Cardano.Ledger.Mary.Value
   )
 where
 
-import Cardano.Binary
-  ( FromCBOR,
-    ToCBOR,
-    encodeListLen,
-    fromCBOR,
-    toCBOR,
-  )
+import Cardano.Binary (Decoder, Encoding, FromCBOR, ToCBOR, TokenType (..), decodeInt64, decodeWord64, fromCBOR, peekTokenType, toCBOR)
+import qualified Cardano.Crypto.Hash.Class as Hash
 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
+  ( DecodeMint (..),
+    DecodeNonNegative (..),
+    EncodeMint (..),
+    Val (..),
+  )
 import Control.DeepSeq (NFData (..))
 import Control.Monad (guard)
 import Data.Array (Array)
@@ -41,6 +43,14 @@ import Data.CannonicalMaps
     cannonicalMapUnion,
     pointWise,
   )
+import Data.Coders
+  ( Decode (..),
+    Encode (..),
+    decode,
+    encode,
+    (!>),
+    (<!),
+  )
 import Data.Group (Abelian, Group (..))
 import Data.Map.Internal
   ( Map (..),
@@ -58,8 +68,8 @@ 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 Shelley.Spec.Ledger.Serialization (decodeMap, encodeMap)
 import Prelude hiding (lookup)
 
 -- | Asset Name
@@ -147,24 +157,106 @@ 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
+    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 +265,20 @@ 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 +291,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 +384,13 @@ 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 (DecodeMint, DecodeNonNegative, Val)
 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,12 @@ 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
+  ( DecodeMint (..),
+    DecodeNonNegative,
+    EncodeMint (..),
+    Val (..),
+  )
 import Control.DeepSeq (NFData (..))
 import Data.Coders
   ( Decode (..),
@@ -88,6 +93,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 +105,8 @@ type FamsFrom era =
 type FamsTo era =
   ( Era era,
     ToCBOR (Value era),
+    Compactible (Value era),
+    EncodeMint (Value era),
     ToCBOR (CompactForm (Value era)), -- Arises because TxOut uses Compact form
     ToCBOR (Script era),
     Typeable (Core.Metadata era)
@@ -173,7 +184,7 @@ txSparse (TxBodyRaw inp out cert wdrl fee (ValidityInterval bot top) up hash frg
     !> encodeKeyedStrictMaybe 6 up
     !> encodeKeyedStrictMaybe 7 hash
     !> encodeKeyedStrictMaybe 8 bot
-    !> Omit isZero (Key 9 (To frge))
+    !> Omit isZero (Key 9 (E encodeMint frge))
 
 bodyFields :: FamsFrom era => Word -> Field (TxBodyRaw era)
 bodyFields 0 = field (\x tx -> tx {inputs = x}) (D (decodeSet fromCBOR))
@@ -185,7 +196,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/cddl-files/shelley-ma.cddl

@@ -260,3 +260,17 @@ genesishash           = $hash28
 
 vrf_keyhash           = $hash32
 metadata_hash         = $hash32
+
+; allegra differences
+transaction_body_allegra =
+  { 0 : set<transaction_input>
+  , 1 : [* transaction_output_allegra]
+  , 2 : coin ; fee
+  , ? 3 : uint ; ttl
+  , ? 4 : [* certificate]
+  , ? 5 : withdrawals
+  , ? 6 : update
+  , ? 7 : metadata_hash
+  , ? 8 : uint ; validity interval start
+  }
+transaction_output_allegra = [address, amount : coin]

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