Fixed the failing Reward provenenance test.

shelley/chain-and-ledger/shelley-spec-ledger-test/shelley-spec-ledger-test.cabal

@@ -70,14 +70,14 @@ library
     Test.Shelley.Spec.Ledger.Shrinkers
     Test.Shelley.Spec.Ledger.Utils
     Test.Shelley.Spec.Ledger.PropertyTests
+    Test.Shelley.Spec.Ledger.Rules.TestChain
     Test.TestScenario
   other-modules:
       Test.Shelley.Spec.Ledger.Address.Bootstrap
       Test.Shelley.Spec.Ledger.Address.CompactAddr
       Test.Shelley.Spec.Ledger.ByronTranslation
       Test.Shelley.Spec.Ledger.Examples.Federation
       Test.Shelley.Spec.Ledger.Rules.ClassifyTraces
-      Test.Shelley.Spec.Ledger.Rules.TestChain
       Test.Shelley.Spec.Ledger.Rules.TestDeleg
       Test.Shelley.Spec.Ledger.Rules.TestPool
       Test.Shelley.Spec.Ledger.Rules.TestPoolreap

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rewards.hs

@@ -9,16 +9,13 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Test.Shelley.Spec.Ledger.Rewards (rewardTests, C, defaultMain) where
+module Test.Shelley.Spec.Ledger.Rewards (rewardTests, C, defaultMain, newEpochProp) where
 
 import Cardano.Binary (toCBOR)
 import qualified Cardano.Crypto.DSIGN as Crypto
 import Cardano.Crypto.Hash (MD5, hashToBytes)
 import Cardano.Crypto.Seed (mkSeedFromBytes)
 import qualified Cardano.Crypto.VRF as Crypto
--- Arbitrary(NewEpochState era)
--- instance (EraGen (ShelleyEra C))
-
 import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..), rationalToCoinViaFloor, toDeltaCoin)
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Crypto (VRF)
@@ -125,7 +122,7 @@ import Test.Shelley.Spec.Ledger.Utils
     testGlobals,
     unsafeMkUnitInterval,
   )
-import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty -- (TestTree, defaultMain, testGroup)
 import Test.Tasty.HUnit (testCaseInfo)
 import Test.Tasty.QuickCheck
   ( Gen,
@@ -140,6 +137,9 @@ import Test.Tasty.QuickCheck
     withMaxSuccess,
     (===),
   )
+import Test.Shelley.Spec.Ledger.Rules.TestChain(forAllChainTrace)
+import Control.State.Transition.Trace(SourceSignalTarget (..), sourceSignalTargets)
+import Shelley.Spec.Ledger.STS.Chain (ChainState (..))
 
 -- ========================================================================
 -- Bounds and Constants --
@@ -423,8 +423,8 @@ sameWithOrWithoutProvenance ::
   (Core.PParams era ~ PParams era) =>
   Globals ->
   NewEpochState era ->
-  Bool
-sameWithOrWithoutProvenance globals newepochstate = with == without
+  Property
+sameWithOrWithoutProvenance globals newepochstate = with === without
   where
     (with, _) = getRewardInfo globals newepochstate
     without = justRewardInfo globals newepochstate
@@ -433,8 +433,9 @@ nothingInNothingOut ::
   forall era.
   (Core.PParams era ~ PParams era) =>
   NewEpochState era ->
-  Bool
+  Property
 nothingInNothingOut newepochstate =
+  counterexample "nothingInNothingOut fails" $
   runReader
     (preservesNothing $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc k)
     globals
@@ -455,8 +456,9 @@ justInJustOut ::
   forall era.
   (Core.PParams era ~ PParams era) =>
   NewEpochState era ->
-  Bool
+  Property
 justInJustOut newepochstate =
+  counterexample "justInJustOut fails" $
   runReader
     (preservesJust def $ createRUpd slotsPerEpoch blocksmade epochstate maxsupply asc k)
     globals
@@ -542,9 +544,10 @@ rewardOnePool
           else Map.insert
       potentialRewards =
         f (getRwdCred $ _poolRAcnt pool) lReward mRewards
-      rewards' = Map.filter (/= Coin 0) $ eval (addrsRew ◁ potentialRewards)
+      rewards' = Map.filter (/= Coin 0) $ (eval (addrsRew ◁ potentialRewards))
+
 
-rewardOld ::
+rewardOld :: forall era.
   PParams era ->
   BlocksMade (Crypto era) ->
   Coin ->
@@ -574,6 +577,7 @@ rewardOld
     where
       totalBlocks = sum b
       Coin activeStake = fold . unStake $ stake
+      results :: [(KeyHash 'StakePool (Crypto era),Maybe (Map (Credential 'Staking (Crypto era)) Coin),Likelihood)]
       results = do
         (hk, pparams) <- Map.toList poolParams
         let sigma = if totalStake == 0 then 0 else fromIntegral pstake % fromIntegral totalStake
@@ -606,7 +610,7 @@ rewardOld
         if HardForks.aggregatedRewards pp
           then Map.unionsWith (<>)
           else Map.unions
-      rewards' = f . catMaybes $ fmap (\(_, x, _) -> x) results
+      rewards' = f . catMaybes $ fmap (\ (_, x, _) -> x) results
       hs = Map.fromList $ fmap (\(hk, _, l) -> (hk, l)) results
 
 data RewardUpdateOld crypto = RewardUpdateOld
@@ -674,8 +678,11 @@ createRUpdOld slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm)
         nonMyopicOld = (updateNonMyopic nm _R newLikelihoods)
       }
 
-oldEqualsNew :: forall era. (Core.PParams era ~ PParams era) => NewEpochState era -> Property
-oldEqualsNew newepochstate = old === new
+oldEqualsNew :: forall era.
+   ( era ~ C,
+     Core.PParams era ~ PParams era
+   ) => NewEpochState era -> Property
+oldEqualsNew newepochstate = (old===new)
   where
     globals = testGlobals
     epochstate = nesEs newepochstate
@@ -714,6 +721,21 @@ oldEqualsNewOn newepochstate = old === new
     asc = activeSlotCoeff globals
     k = securityParameter testGlobals
 
+
+lastElem :: [a] -> Maybe a
+lastElem [a] = Just a
+lastElem [] = Nothing
+lastElem (_ : xs) = lastElem xs
+
+-- | Provide a legitimate NewEpochState to make an test Property
+newEpochProp :: Word64 -> (NewEpochState C -> Property) -> Property
+newEpochProp tracelen propf = withMaxSuccess 100 $
+  forAllChainTrace @C tracelen $ \tr ->
+     case (lastElem (sourceSignalTargets tr)) of
+       Just(SourceSignalTarget {target}) -> propf (chainNes target)
+       _ -> True === True
+
+
 -- ================================================================
 
 reward ::
@@ -765,17 +787,20 @@ rewardPulser
 
 -- ==================================================================
 
+chainlen :: Word64
+chainlen = 5
+
 rewardTests :: TestTree
 rewardTests =
   testGroup
     "Reward Tests"
     [ testProperty
         "Sum of rewards is bounded by reward pot"
         (withMaxSuccess numberOfTests (rewardsBoundedByPot (Proxy @C))),
-      testProperty "provenance does not affect result" (sameWithOrWithoutProvenance @C testGlobals),
-      testProperty "ProvM preserves Nothing" (nothingInNothingOut @C),
-      testProperty "ProvM preserves Just" (justInJustOut @C),
-      testProperty "oldstyle (aggregate immediately) matches newstyle (late aggregation) with provenance off style" (oldEqualsNew @C),
-      testProperty "oldstyle (aggregate immediately) matches newstyle (late aggregation) with provenance on style" (oldEqualsNewOn @C),
+      testProperty "provenance does not affect result" (newEpochProp chainlen (sameWithOrWithoutProvenance @C testGlobals)),
+      testProperty "ProvM preserves Nothing" (newEpochProp chainlen (nothingInNothingOut @C)),
+      testProperty "ProvM preserves Just" (newEpochProp chainlen (justInJustOut @C)),
+      testProperty "oldstyle (aggregate immediately) matches newstyle (late aggregation) with provenance off style" (newEpochProp chainlen (oldEqualsNew @C)),
+      testProperty "oldstyle (aggregate immediately) matches newstyle (late aggregation) with provenance on style" (newEpochProp chainlen (oldEqualsNewOn @C)),
       testCaseInfo "Reward Provenance works" (rewardsProvenance (Proxy @C))
     ]

shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/Rules/TestChain.hs

@@ -18,6 +18,7 @@ module Test.Shelley.Spec.Ledger.Rules.TestChain
     poolProperties,
     -- Test Delegation
     delegProperties,
+    forAllChainTrace,
   )
 where