Adds Pulsing to reward calculation (second try)

alonzo/impl/src/Cardano/Ledger/Alonzo/Data.hs

@@ -75,19 +75,19 @@ instance FromCBOR (Annotator Plutus.Data) where
   fromCBOR = decode (Summands "PlutusData" decPlutus)
     where
       decPlutus :: Word -> Decode 'Open (Annotator Plutus.Data)
-      decPlutus 0 = Ann (SumD Plutus.Constr) <*! (Ann From) <*! fromListA From
-      decPlutus 1 = Ann (SumD Plutus.Map) <*! fromListA (fromPairAA From From)
-      decPlutus 2 = Ann (SumD Plutus.List) <*! fromListA From
+      decPlutus 0 = Ann (SumD Plutus.Constr) <*! (Ann From) <*! listDecodeA From
+      decPlutus 1 = Ann (SumD Plutus.Map) <*! listDecodeA (pairDecodeA From From)
+      decPlutus 2 = Ann (SumD Plutus.List) <*! listDecodeA From
       decPlutus 3 = Ann (SumD Plutus.I <! From)
       decPlutus 4 = Ann (SumD Plutus.B <! From)
       decPlutus n = Invalid n
 
 instance ToCBOR Plutus.Data where
   toCBOR x = encode (encPlutus x)
     where
-      encPlutus (Plutus.Constr tag args) = Sum Plutus.Constr 0 !> To tag !> toList args
-      encPlutus (Plutus.Map pairs) = Sum Plutus.Map 1 !> toList pairs
-      encPlutus (Plutus.List xs) = Sum Plutus.List 2 !> toList xs
+      encPlutus (Plutus.Constr tag args) = Sum Plutus.Constr 0 !> To tag !> listEncode args
+      encPlutus (Plutus.Map pairs) = Sum Plutus.Map 1 !> listEncode pairs
+      encPlutus (Plutus.List xs) = Sum Plutus.List 2 !> listEncode xs
       encPlutus (Plutus.I i) = Sum Plutus.I 3 !> To i
       encPlutus (Plutus.B bytes) = Sum Plutus.B 4 !> To bytes
 
@@ -158,9 +158,9 @@ encodeRaw ::
   Encode ('Closed 'Dense) (AuxiliaryDataRaw era)
 encodeRaw s d m =
   ( Rec AuxiliaryDataRaw
-      !> E encodeFoldable s
-      !> E encodeFoldable d
-      !> E encodeFoldable m
+      !> setEncode s
+      !> setEncode d
+      !> setEncode m
   )
 
 instance
@@ -173,9 +173,9 @@ instance
   fromCBOR =
     decode
       ( Ann (RecD AuxiliaryDataRaw)
-          <*! D (decodeAnnSet fromCBOR)
-          <*! D (decodeAnnSet fromCBOR)
-          <*! D (decodeAnnSet fromCBOR)
+          <*! setDecodeA From
+          <*! setDecodeA From
+          <*! setDecodeA From
       )
 
 -- ================================================================================

alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs

@@ -36,7 +36,6 @@ where
 
 import Cardano.Binary
   ( Annotator,
-    Decoder,
     FromCBOR (..),
     ToCBOR (..),
     encodePreEncoded,
@@ -65,6 +64,8 @@ import Data.Coders
     decode,
     encode,
     field,
+    mapDecodeA,
+    mapEncode,
     (!>),
     (<*!),
   )
@@ -92,8 +93,6 @@ import Shelley.Spec.Ledger.PParams (HKD, ProtVer (..))
 import Shelley.Spec.Ledger.Serialization
   ( FromCBORGroup (..),
     ToCBORGroup (..),
-    decodeMapTraverse,
-    encodeMap,
     mapToCBOR,
     ratioFromCBOR,
     ratioToCBOR,
@@ -213,7 +212,7 @@ instance (Era era) => ToCBOR (PParams era) where
             !> To minPoolCost'
             -- new/updated for alonzo
             !> To adaPerUTxOByte'
-            !> E (encodeMap toCBOR toCBOR) costmdls'
+            !> mapEncode costmdls'
             !> To prices'
             !> To maxTxExUnits'
             !> To maxBlockExUnits'
@@ -243,19 +242,12 @@ instance
         <*! Ann (D fromCBORGroup) -- _protocolVersion :: ProtVer
         <*! Ann From -- _minPoolCost     :: Natural
         -- new/updated for alonzo
-        <*! Ann From -- _adaPerUTxOByte  ::
-        <*! D ((splitMapFromCBOR fromCBOR fromCBOR) :: (forall s. Decoder s (Annotator (Map Language CostModel))))
+        <*! Ann From -- _adaPerUTxOByte  :: Coin
+        <*! mapDecodeA (Ann From) From -- _costmdls :: (Map Language CostModel)
         <*! Ann From -- _prices = prices',
         <*! Ann From -- _maxTxExUnits = maxTxExUnits',
         <*! Ann From -- _maxBlockExUnits = maxBlockExUnits'
 
-splitMapFromCBOR ::
-  Ord dom =>
-  Decoder s dom ->
-  Decoder s (Annotator rng) ->
-  Decoder s (Annotator (Map dom rng))
-splitMapFromCBOR a b = decodeMapTraverse (pure <$> a) b
-
 -- | Returns a basic "empty" `PParams` structure with all zero values.
 emptyPParams :: PParams era
 emptyPParams =
@@ -396,7 +388,7 @@ updateField 13 = fieldNorm (\x up -> up {_extraEntropy = x}) From
 updateField 14 = fieldNorm (\x up -> up {_protocolVersion = x}) From
 updateField 15 = fieldNorm (\x up -> up {_minPoolCost = x}) From
 updateField 16 = fieldNorm (\x up -> up {_adaPerUTxOByte = x}) From
-updateField 17 = fieldAnn (\x up -> up {_costmdls = x}) (D (splitMapFromCBOR fromCBOR fromCBOR))
+updateField 17 = fieldAnn (\x up -> up {_costmdls = x}) (mapDecodeA (Ann From) From)
 updateField 18 = fieldNorm (\x up -> up {_prices = x}) From
 updateField 19 = fieldNorm (\x up -> up {_maxTxExUnits = x}) From
 updateField 20 = fieldNorm (\x up -> up {_maxBlockExUnits = x}) From
@@ -420,7 +412,7 @@ instance Era era => ToCBOR (ProposedPPUpdates era) where
   toCBOR (ProposedPPUpdates m) = mapToCBOR m
 
 instance Era era => FromCBOR (Annotator (ProposedPPUpdates era)) where
-  fromCBOR = (ProposedPPUpdates <$>) <$> splitMapFromCBOR fromCBOR fromCBOR
+  fromCBOR = (ProposedPPUpdates <$>) <$> (decode (mapDecodeA (Ann From) From)) -- splitMapFromCBOR fromCBOR fromCBOR
 
 emptyPPPUpdates :: ProposedPPUpdates era
 emptyPPPUpdates = ProposedPPUpdates Map.empty

alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs

@@ -141,7 +141,6 @@ import Shelley.Spec.Ledger.Coin (Coin (..))
 import Shelley.Spec.Ledger.Credential (Credential (ScriptHashObj))
 import Shelley.Spec.Ledger.Delegation.Certificates (DCert (..))
 import Shelley.Spec.Ledger.Scripts (ScriptHash)
-import Shelley.Spec.Ledger.Serialization (decodeMapTraverse)
 import Shelley.Spec.Ledger.Tx (ValidateScript (isNativeScript))
 import Shelley.Spec.Ledger.TxBody (DelegCert (..), Delegation (..), TxIn (..), Wdrl (..), unWdrl)
 import Shelley.Spec.Ledger.UTxO (UTxO (..), balance)
@@ -335,8 +334,8 @@ instance Era era => FromCBOR (Annotator (WitnessPPDataRaw era)) where
   fromCBOR =
     decode
       ( Ann (RecD WitnessPPDataRaw)
-          <*! D (decodeMapTraverse (pure <$> fromCBOR) fromCBOR)
-          <*! D (decodeAnnSet fromCBOR)
+          <*! mapDecodeA (Ann From) From
+          <*! setDecodeA From
       )
 
 newtype WitnessPPData era = WitnessPPDataConstr (MemoBytes (WitnessPPDataRaw era))
@@ -359,7 +358,7 @@ pattern WitnessPPData mp s <-
     WitnessPPData mp s =
       WitnessPPDataConstr
         . memoBytes
-        $ (Rec WitnessPPDataRaw !> To mp !> To s)
+        $ (Rec WitnessPPDataRaw !> mapEncode mp !> setEncode s)
 
 instance (c ~ Crypto era) => HashAnnotated (WitnessPPData era) EraIndependentWitnessPPData c
 

alonzo/impl/src/Cardano/Ledger/Alonzo/TxWitness.hs

@@ -45,7 +45,6 @@ import Cardano.Ledger.Pretty
     ppWitVKey,
     ppWord64,
   )
-import Control.Applicative (liftA2)
 import Data.Coders
 import Data.Map.Strict (Map)
 import Data.MemoBytes (Mem, MemoBytes (..), memoBytes)
@@ -59,11 +58,6 @@ import NoThunks.Class (NoThunks)
 import Shelley.Spec.Ledger.Address.Bootstrap (BootstrapWitness)
 import Shelley.Spec.Ledger.Keys
 import Shelley.Spec.Ledger.Scripts (ScriptHash)
-import Shelley.Spec.Ledger.Serialization
-  ( decodeMapTraverse,
-    mapFromCBOR,
-    mapToCBOR,
-  )
 import Shelley.Spec.Ledger.TxBody (WitVKey)
 
 -- ==========================================
@@ -214,28 +208,18 @@ encodeWitnessRaw ::
   Encode ('Closed 'Dense) (TxWitnessRaw era)
 encodeWitnessRaw a b c d e =
   Rec TxWitnessRaw
-    !> E encodeFoldable a
-    !> E encodeFoldable b
-    !> E mapToCBOR c
-    !> E mapToCBOR d
-    !> E mapToCBOR e
+    !> setEncode a
+    !> setEncode b
+    !> mapEncode c
+    !> mapEncode d
+    !> mapEncode e
 
 -- TxWitness includes a field with type: (Map RdmrPtr (Data era, ExUnits))
 -- We only have a (ToCBOR (Annotator (Data era))) instance, so we need a special
 -- way to decode a Map where one half of its range has only a (FromCBOR (Annotator _))
 -- instance. We have to be careful since the map is encodedwith 'mapToCBOR' and the
--- decoder needs to be consistent with that encoding.
-
-splitMapFromCBOR ::
-  Ord dom =>
-  Decoder s dom ->
-  Decoder s (Annotator rngLeft) ->
-  Decoder s rngRight ->
-  Decoder s (Annotator (Map dom (rngLeft, rngRight)))
-splitMapFromCBOR a b c = decodeMapTraverse (pure <$> a) (liftPair <$> decodePair b c)
-  where
-    liftPair :: (Annotator a, b) -> Annotator (a, b)
-    liftPair (x, y) = liftA2 (,) x (pure y)
+-- decoder needs to be consistent with that encoding. So we use
+-- fromMapXA From (fromPairAX From From)  to decode that field
 
 instance
   ( Era era,
@@ -249,11 +233,11 @@ instance
   fromCBOR =
     decode $
       Ann (RecD TxWitnessRaw)
-        <*! D (fmap Set.fromList . sequence <$> decodeList fromCBOR)
-        <*! D (fmap Set.fromList . sequence <$> decodeList fromCBOR)
-        <*! D (sequence <$> mapFromCBOR)
-        <*! D (sequence <$> mapFromCBOR)
-        <*! D (splitMapFromCBOR fromCBOR fromCBOR fromCBOR)
+        <*! setDecodeA From
+        <*! setDecodeA From
+        <*! mapDecodeA (Ann From) From
+        <*! mapDecodeA (Ann From) From
+        <*! mapDecodeA (Ann From) (pairDecodeA From (Ann From))
 
 deriving via
   (Mem (TxWitnessRaw era))

semantics/executable-spec/small-steps.cabal

@@ -34,6 +34,7 @@ library
                      , Data.CanonicalMaps
                      , Data.MemoBytes
                      , Data.Coders
+                     , Data.Pulse
                      , Control.Provenance
                      , Control.Iterate.SetAlgebra
                      , Control.Iterate.Collect

semantics/executable-spec/src/Control/Provenance.hs

@@ -31,6 +31,7 @@ module Control.Provenance
     runProv,
     runWithProv,
     runOtherProv,
+    liftProv,
     dump,
 
     -- * Operations in Prov instantiation
@@ -182,6 +183,15 @@ runOtherProv initial other = do
 {-# INLINE runOtherProv #-}
 
 
+-- | lift a provenenace computation from one provenance type (s1) to another (s2)
+liftProv :: Monad m => ProvM s1 m a -> s1 -> (a -> s1 -> s2 -> s2) -> ProvM s2 m a
+liftProv computation inits1 combine =
+  do (a,blackbox) <- runOtherProv inits1 computation
+     modifyWithBlackBox blackbox (combine a)
+     pure a
+{-# INLINE liftProv #-}
+
+
 -- =======================================================================
 {- | A special case of the ProvM Monad, where the state type is Store
 a (Map Text PObject), where PObject is a dynamically typed value. This