Skip to content

Commit 25664e1

Browse files
TimSheardTimSheard
committed
Added Data.Incremental with class(ILC) and basic instances (Map,MonoidMap,Total) tests.
Added ILC instances for Core: Coin, UMap, DPState, DState, PState, UTxOState etc. Added ILC instances for (Diff DPState), (Diff DState) (Diff UTxOstate) etc. Add property tests for ILC invariants for every ILC instance. Rewrote the "POOL" STS rule to use differences (Diff PState), and all the POOL tests Added the Conway era HSpec test directory: eras/conway/impl/test
1 parent c721b2a commit 25664e1

File tree

33 files changed

+1293
-70
lines changed

33 files changed

+1293
-70
lines changed

‎eras/conway/impl/cardano-ledger-conway.cabal‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -58,6 +58,7 @@ library
5858
aeson,
5959
bytestring,
6060
cardano-crypto-class,
61+
cardano-data,
6162
cardano-ledger-binary >=1.1,
6263
cardano-ledger-allegra >=1.1,
6364
cardano-ledger-alonzo >=1.1,
@@ -97,3 +98,22 @@ library testlib
9798
cardano-ledger-core,
9899
cardano-ledger-mary:testlib,
99100
small-steps
101+
102+
test-suite tests
103+
type: exitcode-stdio-1.0
104+
main-is: Main.hs
105+
hs-source-dirs: test
106+
other-modules: Test.Cardano.Ledger.Conway.DiffSpec
107+
default-language: Haskell2010
108+
ghc-options:
109+
-Wall -Wcompat -Wincomplete-record-updates
110+
-Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields
111+
-Wunused-packages -threaded -rtsopts -with-rtsopts=-N
112+
113+
build-depends:
114+
base,
115+
cardano-ledger-core:{cardano-ledger-core, testlib},
116+
cardano-ledger-conway,
117+
testlib,
118+
cardano-ledger-core,
119+
cardano-data:testlib

‎eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs‎

Lines changed: 69 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
{-# LANGUAGE DeriveGeneric #-}
33
{-# LANGUAGE DerivingStrategies #-}
44
{-# LANGUAGE FlexibleContexts #-}
5+
{-# LANGUAGE FlexibleInstances #-}
56
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
67
{-# LANGUAGE OverloadedStrings #-}
78
{-# LANGUAGE RecordWildCards #-}
@@ -37,6 +38,7 @@ module Cardano.Ledger.Conway.Governance (
3738
GovernanceProcedure (..),
3839
Anchor (..),
3940
AnchorDataHash,
41+
Diff (EnactState', RatifyState', ConwayGovernance'),
4042
) where
4143

4244
import Cardano.Crypto.Hash.Class (hashToTextAsHex)
@@ -74,6 +76,14 @@ import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
7476
import Data.Aeson.Types (ToJSONKey (..), toJSONKeyText)
7577
import Data.ByteString (ByteString)
7678
import Data.Default.Class (Default (..))
79+
import Data.Functor.Identity (Identity)
80+
import Data.Incremental (
81+
Diff (Total', Zero),
82+
ILC (..),
83+
Total,
84+
applyTotal,
85+
($$),
86+
)
7787
import Data.Map.Strict (Map)
7888
import Data.Sequence.Strict (StrictSeq)
7989
import Data.Set (Set)
@@ -438,6 +448,16 @@ data EnactState era = EnactState
438448
}
439449
deriving (Generic)
440450

451+
instance ILC (EnactState era) where
452+
newtype Diff (EnactState era) = EnactState' (Diff (Total (EnactState era)))
453+
applyDiff x (EnactState' y) = applyTotal x y
454+
extend (EnactState' x) (EnactState' y) = EnactState' $ extend x y
455+
zero = EnactState' Zero
456+
totalDiff x = EnactState' (Total' x)
457+
458+
deriving instance Eq (PParamsHKD Identity era) => Eq (Diff (EnactState era))
459+
deriving instance Show (PParamsHKD Identity era) => Show (Diff (EnactState era))
460+
441461
instance EraPParams era => ToJSON (EnactState era) where
442462
toJSON = object . toEnactStatePairs
443463
toEncoding = pairs . mconcat . toEnactStatePairs
@@ -453,8 +473,7 @@ toEnactStatePairs cg@(EnactState _ _ _ _ _ _) =
453473
, "withdrawals" .= ensWithdrawals
454474
]
455475

456-
deriving instance Eq (PParams era) => Eq (EnactState era)
457-
476+
deriving instance (Eq (PParamsHKD Identity era), Eq (PParams era)) => Eq (EnactState era)
458477
deriving instance Show (PParams era) => Show (EnactState era)
459478

460479
instance EraPParams era => Default (EnactState era) where
@@ -505,6 +524,29 @@ data RatifyState era = RatifyState
505524
}
506525
deriving (Generic, Eq, Show)
507526

527+
instance ILC (RatifyState era) where
528+
data Diff (RatifyState era) = RatifyState'
529+
{ diffRsEnactState :: !(Diff (EnactState era))
530+
, diffRsFuture :: !(Diff (Total (StrictSeq (GovernanceActionId (EraCrypto era), GovernanceActionState era))))
531+
}
532+
applyDiff RatifyState {..} RatifyState' {..} =
533+
RatifyState
534+
{ rsEnactState = rsEnactState $$ diffRsEnactState
535+
, rsFuture = case diffRsFuture of
536+
Zero -> rsFuture
537+
Total' x -> x
538+
}
539+
extend x y =
540+
RatifyState'
541+
{ diffRsEnactState = extend (diffRsEnactState x) (diffRsEnactState y)
542+
, diffRsFuture = extend (diffRsFuture x) (diffRsFuture y)
543+
}
544+
zero = RatifyState' zero zero
545+
totalDiff (RatifyState x y) = RatifyState' (totalDiff x) (Total' y)
546+
547+
deriving instance EraPParams era => Eq (Diff (RatifyState era))
548+
deriving instance EraPParams era => Show (Diff (RatifyState era))
549+
508550
instance EraPParams era => Default (RatifyState era)
509551

510552
instance EraPParams era => DecCBOR (RatifyState era) where
@@ -549,6 +591,31 @@ data ConwayGovernance era = ConwayGovernance
549591
}
550592
deriving (Generic, Eq, Show)
551593

594+
instance ILC (ConwayGovernance era) where
595+
data Diff (ConwayGovernance era) = ConwayGovernance'
596+
{ diffCgTally :: !(Diff (Map (GovernanceActionId (EraCrypto era)) (GovernanceActionState era)))
597+
, diffCgRatify :: !(Diff (RatifyState era))
598+
, diffCgVoterRoles :: !(Diff (Map (Credential 'Voting (EraCrypto era)) VoterRole))
599+
}
600+
applyDiff ConwayGovernance {..} ConwayGovernance' {..} =
601+
ConwayGovernance
602+
{ cgTally = ConwayTallyState (unConwayTallyState cgTally $$ diffCgTally)
603+
, cgRatify = cgRatify $$ diffCgRatify
604+
, cgVoterRoles = cgVoterRoles $$ diffCgVoterRoles
605+
}
606+
extend x y =
607+
ConwayGovernance'
608+
{ diffCgTally = extend (diffCgTally x) (diffCgTally y)
609+
, diffCgRatify = extend (diffCgRatify x) (diffCgRatify y)
610+
, diffCgVoterRoles = extend (diffCgVoterRoles x) (diffCgVoterRoles y)
611+
}
612+
zero = ConwayGovernance' zero zero zero
613+
totalDiff (ConwayGovernance (ConwayTallyState x) y z) =
614+
ConwayGovernance' (totalDiff x) (totalDiff y) (totalDiff z)
615+
616+
deriving instance (EraPParams era) => (Eq (Diff (ConwayGovernance era)))
617+
deriving instance (EraPParams era) => (Show (Diff (ConwayGovernance era)))
618+
552619
cgTallyL :: Lens' (ConwayGovernance era) (ConwayTallyState era)
553620
cgTallyL = lens cgTally (\x y -> x {cgTally = y})
554621

‎eras/conway/impl/test/Main.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module Main where
2+
3+
import Test.Cardano.Ledger.Common
4+
import Test.Cardano.Ledger.Conway.DiffSpec (conwayDiffSpecs)
5+
6+
main :: IO ()
7+
main =
8+
ledgerTestMain $
9+
describe "Conway tests" $ do
10+
conwayDiffSpecs

‎eras/conway/impl/test/Test/Cardano/Ledger/Conway/DiffSpec.hs‎

Lines changed: 31 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
{-# LANGUAGE TypeApplications #-}
2+
3+
module Test.Cardano.Ledger.Conway.DiffSpec (conwayDiffSpecs) where
4+
5+
import Cardano.Ledger.Conway (ConwayEra)
6+
import Cardano.Ledger.Conway.Governance
7+
import Cardano.Ledger.Crypto (StandardCrypto)
8+
import Test.Cardano.Data (
9+
propExtend,
10+
propZero,
11+
)
12+
import Test.Cardano.Ledger.Common
13+
import Test.Cardano.Ledger.Conway.Arbitrary ()
14+
15+
-- ==========================================================
16+
17+
conwayDiffSpecs :: Spec
18+
conwayDiffSpecs = describe "ILC Diff tests" $ do
19+
describe "Diff EnactState" $ do
20+
propZero (arbitrary @(EnactState (ConwayEra StandardCrypto)))
21+
propExtend (arbitrary @(EnactState (ConwayEra StandardCrypto))) arbitrary
22+
describe "Diff RatifyState" $ do
23+
propZero (arbitrary @(RatifyState (ConwayEra StandardCrypto)))
24+
propExtend (arbitrary @(RatifyState (ConwayEra StandardCrypto))) arbitrary
25+
describe "Diff GovernanceState" $ do
26+
propZero (arbitrary @(GovernanceState (ConwayEra StandardCrypto)))
27+
propExtend (arbitrary @(GovernanceState (ConwayEra StandardCrypto))) arbitrary
28+
29+
-- To run theses tests in ghci, uncomment and type 'main'
30+
-- main :: IO ()
31+
-- main = hspec $ conwayDiffSpecs

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs‎

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
34
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
45
{-# LANGUAGE StandaloneDeriving #-}
56
{-# LANGUAGE TypeFamilies #-}
@@ -8,6 +9,7 @@
89

910
module Test.Cardano.Ledger.Conway.Arbitrary () where
1011

12+
import Cardano.Ledger.BaseTypes (StrictMaybe)
1113
import Cardano.Ledger.Binary (Sized)
1214
import Cardano.Ledger.Conway.Core
1315
import Cardano.Ledger.Conway.Delegation.Certificates
@@ -17,6 +19,7 @@ import Cardano.Ledger.Conway.Rules
1719
import Cardano.Ledger.Conway.TxBody
1820
import Cardano.Ledger.Crypto (Crypto)
1921
import Control.State.Transition.Extended (STS (Event))
22+
import Data.Functor.Identity (Identity)
2023
import Test.Cardano.Ledger.Alonzo.Arbitrary ()
2124
import Test.Cardano.Ledger.Babbage.Arbitrary ()
2225
import Test.Cardano.Ledger.Common
@@ -230,3 +233,40 @@ instance
230233
Arbitrary (ConwayTickfEvent era)
231234
where
232235
arbitrary = undefined
236+
237+
------------------------------------------------------------------------------------------
238+
-- Cardano.Ledger.Conway ILC instances ---------------------------------------------------
239+
------------------------------------------------------------------------------------------
240+
{-
241+
src/Cardano/Ledger/Conway/Governance.hs
242+
448:instance ILC (EnactState era) where
243+
521:instance ILC (RatifyState era) where
244+
584:instance ILC (ConwayGovernance era) where
245+
-}
246+
247+
instance
248+
( Era era
249+
, Arbitrary (PParamsHKD Identity era)
250+
, Arbitrary (PParamsHKD StrictMaybe era)
251+
) =>
252+
Arbitrary (Diff (EnactState era))
253+
where
254+
arbitrary = EnactState' <$> arbitrary
255+
256+
instance
257+
( Era era
258+
, Arbitrary (PParamsHKD Identity era)
259+
, Arbitrary (PParamsHKD StrictMaybe era)
260+
) =>
261+
Arbitrary (Diff (RatifyState era))
262+
where
263+
arbitrary = RatifyState' <$> arbitrary <*> arbitrary
264+
265+
instance
266+
( Era era
267+
, Arbitrary (PParamsHKD Identity era)
268+
, Arbitrary (PParamsHKD StrictMaybe era)
269+
) =>
270+
Arbitrary (Diff (ConwayGovernance era))
271+
where
272+
arbitrary = ConwayGovernance' <$> arbitrary <*> arbitrary <*> arbitrary

‎eras/conway/test-suite/cardano-ledger-conway-test.cabal‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -74,9 +74,10 @@ test-suite cardano-ledger-conway-test
7474
bytestring,
7575
cardano-ledger-allegra,
7676
cardano-ledger-alonzo,
77+
cardano-data:testlib,
7778
cardano-ledger-babbage,
78-
cardano-ledger-conway,
79+
cardano-ledger-conway:{cardano-ledger-conway, testlib},
7980
cardano-ledger-conway-test,
80-
cardano-ledger-core,
81+
cardano-ledger-core:{cardano-ledger-core, testlib},
8182
cardano-ledger-shelley-test,
8283
tasty

‎eras/conway/test-suite/test/Tests.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
module Main where
55

66
import Cardano.Ledger.Conway (Conway)
7+
import Test.Cardano.Ledger.Common (hspec)
78
import qualified Test.Cardano.Ledger.Conway.Serialisation.CDDL as CDDL
89
import qualified Test.Cardano.Ledger.Conway.Serialisation.Roundtrip as Roundtrip
910
import Test.Tasty (TestTree, defaultMain, testGroup)

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs‎

Lines changed: 29 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
1+
{-# LANGUAGE DataKinds #-}
12
{-# LANGUAGE DeriveGeneric #-}
23
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE FlexibleInstances #-}
35
{-# LANGUAGE OverloadedStrings #-}
46
{-# LANGUAGE RecordWildCards #-}
57
{-# LANGUAGE ScopedTypeVariables #-}
@@ -11,6 +13,7 @@
1113
module Cardano.Ledger.Shelley.Governance (
1214
EraGovernance (..),
1315
ShelleyPPUPState (..),
16+
Diff (ShelleyPPUPState'),
1417
) where
1518

1619
import Cardano.Ledger.Binary (
@@ -23,13 +26,16 @@ import Cardano.Ledger.Binary (
2326
import Cardano.Ledger.Binary.Coders (Decode (..), decode, (<!))
2427
import Cardano.Ledger.Core
2528
import Cardano.Ledger.Crypto (Crypto)
29+
import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
2630
import Cardano.Ledger.Shelley.Era (ShelleyEra)
27-
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates, emptyPPPUpdates)
31+
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (..), emptyPPPUpdates)
2832
import Cardano.Ledger.TreeDiff (ToExpr)
2933
import Control.DeepSeq (NFData)
3034
import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
3135
import Data.Default.Class (Default (..))
36+
import Data.Incremental (ILC (..), ($$))
3237
import Data.Kind (Type)
38+
import Data.Map (Map)
3339
import GHC.Generics (Generic)
3440
import NoThunks.Class (NoThunks (..))
3541

@@ -72,6 +78,28 @@ data ShelleyPPUPState era = ShelleyPPUPState
7278
}
7379
deriving (Generic)
7480

81+
instance ILC (ShelleyPPUPState era) where
82+
data Diff (ShelleyPPUPState era) = ShelleyPPUPState'
83+
{ diffProposals :: !(Diff (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)))
84+
, diffFutureProposals :: !(Diff (Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)))
85+
}
86+
applyDiff ShelleyPPUPState {..} ShelleyPPUPState' {..} =
87+
ShelleyPPUPState
88+
{ proposals = ProposedPPUpdates (unProposedPPUpdates proposals $$ diffProposals)
89+
, futureProposals = ProposedPPUpdates (unProposedPPUpdates futureProposals $$ diffProposals)
90+
}
91+
extend x y =
92+
ShelleyPPUPState'
93+
{ diffProposals = extend (diffProposals x) (diffProposals y)
94+
, diffFutureProposals = extend (diffFutureProposals x) (diffFutureProposals y)
95+
}
96+
zero = ShelleyPPUPState' zero zero
97+
totalDiff _ = ShelleyPPUPState' zero zero
98+
99+
deriving instance Show (PParamsUpdate era) => Show (Diff (ShelleyPPUPState era))
100+
101+
deriving instance Eq (PParamsUpdate era) => Eq (Diff (ShelleyPPUPState era))
102+
75103
deriving instance Show (PParamsUpdate era) => Show (ShelleyPPUPState era)
76104

77105
deriving instance Eq (PParamsUpdate era) => Eq (ShelleyPPUPState era)

‎eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -94,6 +94,9 @@ module Cardano.Ledger.Shelley.LedgerState (
9494
lsUTxOStateL,
9595
utxosFeesL,
9696
utxosGovernanceL,
97+
98+
-- * ILC instances
99+
Diff (IStake', UTxOState', LedgerState'),
97100
) where
98101

99102
import Cardano.Ledger.DPState

0 commit comments

Comments
 (0)