From 008df29406ba87d74fcb79a15369c1731c83bc4f Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 10 Dec 2024 19:28:35 -0700 Subject: [PATCH] ledger-state has crpyot removed --- libs/ledger-state/bench/Address.hs | 19 ++- libs/ledger-state/bench/Performance.hs | 4 +- .../src/Cardano/Ledger/State/Orphans.hs | 26 ++-- .../src/Cardano/Ledger/State/Query.hs | 42 +++--- .../src/Cardano/Ledger/State/Schema.hs | 16 +-- .../src/Cardano/Ledger/State/UTxO.hs | 129 +++++++++--------- .../src/Cardano/Ledger/State/Vector.hs | 21 ++- 7 files changed, 126 insertions(+), 131 deletions(-) diff --git a/libs/ledger-state/bench/Address.hs b/libs/ledger-state/bench/Address.hs index a80666dba5a..f246b27221a 100644 --- a/libs/ledger-state/bench/Address.hs +++ b/libs/ledger-state/bench/Address.hs @@ -16,7 +16,6 @@ import Cardano.Ledger.Address import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary import Cardano.Ledger.Credential -import Cardano.Ledger.Crypto import Cardano.Ledger.Keys import Control.DeepSeq (NFData, deepseq) import Criterion.Main @@ -28,11 +27,11 @@ import Test.Cardano.Ledger.Core.Address (decompactAddrOldLazy) main :: IO () main = do - let mkPayment :: Int -> Credential 'Payment StandardCrypto + let mkPayment :: Int -> Credential 'Payment mkPayment = KeyHashObj . payAddr28 - stakeRefBase :: Int -> StakeReference StandardCrypto + stakeRefBase :: Int -> StakeReference stakeRefBase = StakeRefBase . KeyHashObj . stakeAddr28 - mkAddr :: (Int -> StakeReference StandardCrypto) -> Int -> Addr StandardCrypto + mkAddr :: (Int -> StakeReference) -> Int -> Addr mkAddr mkStake n = Addr Mainnet (mkPayment n) (mkStake n) mkPtr n = let ni = toInteger n @@ -41,17 +40,17 @@ main = do count = 10000 seqUnit :: a -> StrictUnit seqUnit x = x `seq` mempty - forcePaymentCred :: Addr StandardCrypto -> StrictUnit + forcePaymentCred :: Addr -> StrictUnit forcePaymentCred = \case Addr _ p _ -> p `seq` mempty _ -> mempty - forceStakingCred :: Addr StandardCrypto -> StrictUnit + forceStakingCred :: Addr -> StrictUnit forceStakingCred = \case Addr _ _ s -> s `deepseq` mempty _ -> mempty - addrs :: (Int -> StakeReference StandardCrypto) -> [Addr StandardCrypto] + addrs :: (Int -> StakeReference) -> [Addr] addrs mkStake = mkAddr mkStake <$> [1 .. count] - partialDeserializeAddr :: ByteString -> Addr StandardCrypto + partialDeserializeAddr :: ByteString -> Addr partialDeserializeAddr = either (error . show) id . decodeFullDecoder' version "Addr" fromCborAddr version = maxBound :: Version @@ -184,14 +183,14 @@ deepseqUnit x = x `deepseq` mempty textDigits :: Int -> T.Text textDigits n = let i = n `mod` 10 in T.pack (take 6 (cycle (show i))) -payAddr28 :: Int -> KeyHash 'Payment StandardCrypto +payAddr28 :: Int -> KeyHash 'Payment payAddr28 n = KeyHash $ fromMaybe "Unexpected PayAddr28" $ hashFromTextAsHex $ textDigits n <> "0405060708090a0b0c0d0e0f12131415161718191a1b1c1d1e" -stakeAddr28 :: Int -> KeyHash 'Staking StandardCrypto +stakeAddr28 :: Int -> KeyHash 'Staking stakeAddr28 n = KeyHash $ fromMaybe "Unexpected StakeAddr28" $ diff --git a/libs/ledger-state/bench/Performance.hs b/libs/ledger-state/bench/Performance.hs index b73cec7d96d..c42d8a94928 100644 --- a/libs/ledger-state/bench/Performance.hs +++ b/libs/ledger-state/bench/Performance.hs @@ -238,7 +238,7 @@ validatedTx3 = \7120c2d3482751b14f06dd41d7ff023eeae6e63933b097c023c1ed19df6a061173c45aa\ \54cceb568ff1886e2716e84e6260df5f6" -mkGlobals :: ShelleyGenesis StandardCrypto -> Globals +mkGlobals :: ShelleyGenesis -> Globals mkGlobals genesis = mkShelleyGlobals genesis epochInfoE where @@ -250,7 +250,7 @@ mkGlobals genesis = getFilteredOldUTxO :: EraTxOut era => NewEpochState era -> - Set (Addr (EraCrypto era)) -> + Set Addr -> UTxO era getFilteredOldUTxO ss addrs = UTxO $ diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs b/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs index 7cfa6d1e558..1de0ff7a8e9 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Orphans.hs @@ -51,7 +51,7 @@ instance PersistField ShortByteString where instance PersistFieldSql ShortByteString where sqlType _ = SqlBlob -instance PersistField (TxId C) where +instance PersistField TxId where toPersistValue = PersistByteString . hashToBytes . extractHash . unTxId fromPersistValue (PersistByteString bs) = case hashFromBytes bs of @@ -59,7 +59,7 @@ instance PersistField (TxId C) where Just h -> Right $ TxId $ unsafeMakeSafeHash h fromPersistValue _ = Left "Unexpected type" -instance PersistFieldSql (TxId C) where +instance PersistFieldSql TxId where sqlType _ = SqlBlob deriving instance PersistField (CompactForm Coin) @@ -102,13 +102,13 @@ decodePersistValue (PersistByteString bs) = Right v -> Right v decodePersistValue _ = Left "Unexpected type" -deriving via Enc (KeyHash r C) instance Typeable r => PersistField (KeyHash r C) +deriving via Enc (KeyHash r) instance Typeable r => PersistField (KeyHash r) -deriving via Enc (KeyHash r C) instance Typeable r => PersistFieldSql (KeyHash r C) +deriving via Enc (KeyHash r) instance Typeable r => PersistFieldSql (KeyHash r) -deriving via Enc (Credential r C) instance Typeable r => PersistField (Credential r C) +deriving via Enc (Credential r) instance Typeable r => PersistField (Credential r) -deriving via Enc (Credential r C) instance Typeable r => PersistFieldSql (Credential r C) +deriving via Enc (Credential r) instance Typeable r => PersistFieldSql (Credential r) deriving via Enc Ptr instance PersistField Ptr @@ -137,20 +137,20 @@ deriving via Enc (PState CurrentEra) instance PersistField (PState CurrentEra) deriving via Enc (PState CurrentEra) instance PersistFieldSql (PState CurrentEra) -deriving via Enc (GenDelegs C) instance PersistField (GenDelegs C) +deriving via Enc GenDelegs instance PersistField GenDelegs -deriving via Enc (GenDelegs C) instance PersistFieldSql (GenDelegs C) +deriving via Enc GenDelegs instance PersistFieldSql GenDelegs -deriving via Enc (PoolParams C) instance PersistField (PoolParams C) +deriving via Enc PoolParams instance PersistField PoolParams -deriving via Enc (PoolParams C) instance PersistFieldSql (PoolParams C) +deriving via Enc PoolParams instance PersistFieldSql PoolParams -instance DecCBOR (NonMyopic C) where +instance DecCBOR NonMyopic where decCBOR = decNoShareCBOR -deriving via Enc (NonMyopic C) instance PersistField (NonMyopic C) +deriving via Enc NonMyopic instance PersistField NonMyopic -deriving via Enc (NonMyopic C) instance PersistFieldSql (NonMyopic C) +deriving via Enc NonMyopic instance PersistFieldSql NonMyopic deriving via Enc (PParams CurrentEra) instance PersistField (PParams CurrentEra) diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs index 0fe6e8ddde2..3022877a3e3 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs @@ -136,7 +136,7 @@ insertSnapShot :: MonadIO m => Key EpochState -> SnapShotType -> - EpochBoundary.SnapShot C -> + EpochBoundary.SnapShot -> ReaderT SqlBackend m () insertSnapShot snapShotEpochStateId snapShotType EpochBoundary.SnapShot {..} = do snapShotId <- insert $ SnapShot {snapShotType, snapShotEpochStateId} @@ -154,7 +154,7 @@ insertSnapShot snapShotEpochStateId snapShotType EpochBoundary.SnapShot {..} = d insertSnapShots :: MonadIO m => Key EpochState -> - EpochBoundary.SnapShots C -> + EpochBoundary.SnapShots -> ReaderT SqlBackend m () insertSnapShots epochStateKey EpochBoundary.SnapShots {..} = do mapM_ @@ -208,7 +208,7 @@ getSnapShotNoSharingM :: MonadResource m => Key EpochState -> SnapShotType -> - ReaderT SqlBackend m (SnapShotM C) + ReaderT SqlBackend m SnapShotM getSnapShotNoSharingM epochStateId snapShotType = do snapShotId <- selectFirst @@ -241,10 +241,10 @@ getSnapShotNoSharingM epochStateId snapShotType = do getSnapShotWithSharingM :: MonadResource m => - [SnapShotM C] -> + [SnapShotM] -> Key EpochState -> SnapShotType -> - ReaderT SqlBackend m (SnapShotM C) + ReaderT SqlBackend m SnapShotM getSnapShotWithSharingM otherSnapShots epochStateId snapShotType = do let internOtherStakes = interns @@ -288,7 +288,7 @@ getSnapShotWithSharingM otherSnapShots epochStateId snapShotType = do getSnapShotsWithSharingM :: MonadResource m => Entity EpochState -> - ReaderT SqlBackend m (SnapShotsM C) + ReaderT SqlBackend m SnapShotsM getSnapShotsWithSharingM (Entity epochStateId EpochState {epochStateSnapShotsFee}) = do mark <- getSnapShotWithSharingM [] epochStateId SnapShotMark set <- getSnapShotWithSharingM [mark] epochStateId SnapShotSet @@ -324,7 +324,7 @@ getSnapShotNoSharing :: MonadResource m => Key EpochState -> SnapShotType -> - ReaderT SqlBackend m (EpochBoundary.SnapShot C) + ReaderT SqlBackend m EpochBoundary.SnapShot getSnapShotNoSharing epochStateId snapShotType = do snapShotId <- selectFirst @@ -358,7 +358,7 @@ getSnapShotNoSharing epochStateId snapShotType = do getSnapShotsNoSharing :: MonadResource m => Entity EpochState -> - ReaderT SqlBackend m (EpochBoundary.SnapShots C) + ReaderT SqlBackend m EpochBoundary.SnapShots getSnapShotsNoSharing (Entity epochStateId EpochState {epochStateSnapShotsFee}) = do mark <- getSnapShotNoSharing epochStateId SnapShotMark set <- getSnapShotNoSharing epochStateId SnapShotSet @@ -376,7 +376,7 @@ getSnapShotsNoSharing (Entity epochStateId EpochState {epochStateSnapShotsFee}) getSnapShotsNoSharingM :: MonadResource m => Entity EpochState -> - ReaderT SqlBackend m (SnapShotsM C) + ReaderT SqlBackend m SnapShotsM getSnapShotsNoSharingM (Entity epochStateId EpochState {epochStateSnapShotsFee}) = do mark <- getSnapShotNoSharingM epochStateId SnapShotMark set <- getSnapShotNoSharingM epochStateId SnapShotSet @@ -392,10 +392,10 @@ getSnapShotsNoSharingM (Entity epochStateId EpochState {epochStateSnapShotsFee}) getSnapShotWithSharing :: MonadResource m => - [EpochBoundary.SnapShot C] -> + [EpochBoundary.SnapShot] -> Key EpochState -> SnapShotType -> - ReaderT SqlBackend m (EpochBoundary.SnapShot C) + ReaderT SqlBackend m EpochBoundary.SnapShot getSnapShotWithSharing otherSnapShots epochStateId snapShotType = do let internOtherStakes = interns @@ -439,7 +439,7 @@ getSnapShotWithSharing otherSnapShots epochStateId snapShotType = do getSnapShotsWithSharing :: MonadResource m => Entity EpochState -> - ReaderT SqlBackend m (EpochBoundary.SnapShots C) + ReaderT SqlBackend m EpochBoundary.SnapShots getSnapShotsWithSharing (Entity epochStateId EpochState {epochStateSnapShotsFee}) = do mark <- getSnapShotWithSharing [] epochStateId SnapShotMark set <- getSnapShotWithSharing [mark] epochStateId SnapShotSet @@ -456,22 +456,22 @@ getSnapShotsWithSharing (Entity epochStateId EpochState {epochStateSnapShotsFee} sourceUTxO :: MonadResource m => - ConduitM () (TxIn.TxIn C, TxOut CurrentEra) (ReaderT SqlBackend m) () + ConduitM () (TxIn.TxIn, TxOut CurrentEra) (ReaderT SqlBackend m) () sourceUTxO = selectSource [] [] .| mapC (\(Entity _ Tx {..}) -> (TxIn.TxIn txInId txInIx, txOut)) sourceWithSharingUTxO :: MonadResource m => - Map.Map (Credential.StakeCredential C) a -> - ConduitM () (TxIn.TxIn C, TxOut CurrentEra) (ReaderT SqlBackend m) () + Map.Map Credential.StakeCredential a -> + ConduitM () (TxIn.TxIn, TxOut CurrentEra) (ReaderT SqlBackend m) () sourceWithSharingUTxO stakeCredentials = sourceUTxO .| mapC (fmap (internBabbageTxOut (`intern` stakeCredentials))) foldDbUTxO :: MonadUnliftIO m => -- | Folding function - (a -> (TxIn.TxIn C, TxOut CurrentEra) -> a) -> + (a -> (TxIn.TxIn, TxOut CurrentEra) -> a) -> -- | Empty acc a -> -- | Path to Sqlite db @@ -679,7 +679,7 @@ loadLedgerStateDStateTxIxSharing :: T.Text -> m ( Shelley.LedgerState CurrentEra - , IntMap.IntMap (Map.Map (TxIn.TxId C) (TxOut CurrentEra)) + , IntMap.IntMap (Map.Map TxIn.TxId (TxOut CurrentEra)) ) loadLedgerStateDStateTxIxSharing fp = runSqlite fp $ do @@ -768,19 +768,19 @@ loadEpochStateWithSharing fp = runSqlite fp $ do & curPParamsEpochStateL .~ epochStatePp loadSnapShotsNoSharing :: - MonadUnliftIO m => T.Text -> Entity EpochState -> m (EpochBoundary.SnapShots C) + MonadUnliftIO m => T.Text -> Entity EpochState -> m EpochBoundary.SnapShots loadSnapShotsNoSharing fp = runSqlite fp . getSnapShotsNoSharing {-# INLINEABLE loadSnapShotsNoSharing #-} loadSnapShotsWithSharing :: - MonadUnliftIO m => T.Text -> Entity EpochState -> m (EpochBoundary.SnapShots C) + MonadUnliftIO m => T.Text -> Entity EpochState -> m EpochBoundary.SnapShots loadSnapShotsWithSharing fp = runSqlite fp . getSnapShotsWithSharing {-# INLINEABLE loadSnapShotsWithSharing #-} -loadSnapShotsNoSharingM :: T.Text -> Entity EpochState -> IO (SnapShotsM C) +loadSnapShotsNoSharingM :: T.Text -> Entity EpochState -> IO SnapShotsM loadSnapShotsNoSharingM fp = runSqlite fp . getSnapShotsNoSharingM {-# INLINEABLE loadSnapShotsNoSharingM #-} -loadSnapShotsWithSharingM :: T.Text -> Entity EpochState -> IO (SnapShotsM C) +loadSnapShotsWithSharingM :: T.Text -> Entity EpochState -> IO SnapShotsM loadSnapShotsWithSharingM fp = runSqlite fp . getSnapShotsWithSharingM {-# INLINEABLE loadSnapShotsWithSharingM #-} diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs index 25f57ff6b08..827ee4d89f4 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Schema.hs @@ -30,11 +30,11 @@ import qualified Data.Map.Strict as Map import Database.Persist.Sqlite import Database.Persist.TH -type FGenDelegs = (Enc (Map.Map (Shelley.FutureGenDeleg C) (Keys.GenDelegPair C))) +type FGenDelegs = (Enc (Map.Map Shelley.FutureGenDeleg Keys.GenDelegPair)) -type CredentialWitness = Credential.Credential 'Keys.Witness C +type CredentialWitness = Credential.Credential 'Keys.Witness -type KeyHashWitness = Keys.KeyHash 'Keys.Witness C +type KeyHashWitness = Keys.KeyHash 'Keys.Witness share [mkPersist sqlSettings, mkMigrate "migrateAll"] @@ -44,7 +44,7 @@ EpochState reserves Coin prevPp (PParams CurrentEra) pp (PParams CurrentEra) - nonMyopic (Shelley.NonMyopic C) + nonMyopic Shelley.NonMyopic snapShotsFee Coin SnapShot @@ -64,7 +64,7 @@ SnapShotDelegation SnapShotPool snapShotId SnapShotId keyHashId KeyHashId - params (Shelley.PoolParams C) + params Shelley.PoolParams UniqueSnapShotPool snapShotId keyHashId LedgerState @@ -82,7 +82,7 @@ UtxoState donation Coin DState fGenDelegs FGenDelegs - genDelegs (Keys.GenDelegs C) + genDelegs Keys.GenDelegs irDeltaReserves DeltaCoin irDeltaTreasury DeltaCoin @@ -94,12 +94,12 @@ KeyHash UniqueKeyHash witness Tx inIx TxIx - inId (TxIn.TxId C) + inId TxIn.TxId out (BabbageTxOut CurrentEra) UniqueTx inIx inId Txs inIx TxIx - inId (TxIn.TxId C) + inId TxIn.TxId out (BabbageTxOut CurrentEra) stakeCredential CredentialId Maybe UniqueTxs inIx inId diff --git a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs index 6c1615f0764..d432d59d6a2 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/UTxO.hs @@ -19,7 +19,6 @@ import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Core import Cardano.Ledger.Credential -import Cardano.Ledger.Crypto import Cardano.Ledger.Keys import Cardano.Ledger.Mary.Value import Cardano.Ledger.PoolDistr (individualPoolStakeVrf) @@ -43,9 +42,7 @@ import Lens.Micro import Prettyprinter import Text.Printf -type C = StandardCrypto - -type CurrentEra = Babbage +type CurrentEra = BabbageEra --- Loading readNewEpochState :: @@ -75,45 +72,45 @@ loadLedgerState fp = esLState . nesEs <$> readNewEpochState fp runConduitFold :: Monad m => ConduitT () a m () -> Fold a b -> m b runConduitFold source (Fold f e g) = (g <$> runConduit (source .| foldlC f e)) -type UTxOFold b = Fold (TxIn C, TxOut CurrentEra) b +type UTxOFold b = Fold (TxIn, TxOut CurrentEra) b -noSharing :: Fold (TxIn C, a) (Map.Map (TxIn C) a) +noSharing :: Fold (TxIn, a) (Map.Map TxIn a) noSharing = Fold (\ !m !(!k, !v) -> Map.insert k v m) mempty id -noSharing_ :: UTxOFold (Map.Map (TxIn C) ()) +noSharing_ :: UTxOFold (Map.Map TxIn ()) noSharing_ = Fold (\ !m !(!k, _) -> Map.insert k () m) mempty id -noSharingMap :: Fold (TxIn C, a) (Map.Map (TxIn C) a) +noSharingMap :: Fold (TxIn, a) (Map.Map TxIn a) noSharingMap = Fold (\ !m !(!k, !v) -> Map.insert k v m) mempty id -noSharingMap_ :: UTxOFold (Map.Map (TxIn C) ()) +noSharingMap_ :: UTxOFold (Map.Map TxIn ()) noSharingMap_ = Fold (\ !m !(!k, _) -> Map.insert k () m) mempty id txIdSharing :: - UTxOFold (Map.Map (TxId C) (IntMap.IntMap (TxOut CurrentEra))) + UTxOFold (Map.Map TxId (IntMap.IntMap (TxOut CurrentEra))) txIdSharing = Fold txIdNestedInsert mempty id -txIdSharing_ :: UTxOFold (Map.Map (TxId C) (IntMap.IntMap ())) +txIdSharing_ :: UTxOFold (Map.Map TxId (IntMap.IntMap ())) txIdSharing_ = Fold (\a v -> txIdNestedInsert a (() <$ v)) mempty id txIdNestedInsert :: - Map.Map (TxId C) (IntMap.IntMap a) -> - (TxIn C, a) -> - Map.Map (TxId C) (IntMap.IntMap a) + Map.Map TxId (IntMap.IntMap a) -> + (TxIn, a) -> + Map.Map TxId (IntMap.IntMap a) txIdNestedInsert !m (TxIn !txId !txIx, !v) = let !e = IntMap.singleton (txIxToInt txIx) v in Map.insertWith (<>) txId e m -txIxSharing :: Fold (TxIn C, a) (IntMap.IntMap (Map.Map (TxId C) a)) +txIxSharing :: Fold (TxIn, a) (IntMap.IntMap (Map.Map TxId a)) txIxSharing = Fold txIxNestedInsert mempty id -txIxSharing_ :: UTxOFold (IntMap.IntMap (Map.Map (TxId C) ())) +txIxSharing_ :: UTxOFold (IntMap.IntMap (Map.Map TxId ())) txIxSharing_ = Fold (\a v -> txIxNestedInsert a (() <$ v)) mempty id txIxNestedInsert :: - IntMap.IntMap (Map.Map (TxId C) a) -> - (TxIn C, a) -> - IntMap.IntMap (Map.Map (TxId C) a) + IntMap.IntMap (Map.Map TxId a) -> + (TxIn, a) -> + IntMap.IntMap (Map.Map TxId a) txIxNestedInsert !im (TxIn !txId !txIx, !v) = let f = \case @@ -121,7 +118,7 @@ txIxNestedInsert !im (TxIn !txId !txIx, !v) = Just !m -> Just $! Map.insert txId v m in IntMap.alter f (txIxToInt txIx) im -totalADA :: Map.Map (TxIn C) (TxOut CurrentEra) -> MaryValue C +totalADA :: Map.Map TxIn (TxOut CurrentEra) -> MaryValue totalADA = foldMap (^. valueTxOutL) readBinUTxO :: @@ -191,10 +188,10 @@ prettyRecord h content = h <> ":" <+> line <> indent 2 (vsep content) infixr 6 <:> data SnapShotStats = SnapShotStats - { sssStake :: !(Stat (Credential 'Staking C)) - , sssDelegationCredential :: !(Stat (Credential 'Staking C)) - , sssDelegationStakePool :: !(Stat (KeyHash 'StakePool C)) - , sssPoolParams :: !(Stat (KeyHash 'StakePool C)) + { sssStake :: !(Stat (Credential 'Staking)) + , sssDelegationCredential :: !(Stat (Credential 'Staking)) + , sssDelegationStakePool :: !(Stat (KeyHash 'StakePool)) + , sssPoolParams :: !(Stat (KeyHash 'StakePool)) , sssPoolParamsStats :: !PoolParamsStats } @@ -228,7 +225,7 @@ instance AggregateStat SnapShotStats where , gsKeyHashStakePool = sssDelegationStakePool <> sssPoolParams } -countSnapShotStat :: SnapShot C -> SnapShotStats +countSnapShotStat :: SnapShot -> SnapShotStats countSnapShotStat SnapShot {..} = SnapShotStats { sssStake = statMapKeys (VMap.toMap (unStake ssStake)) @@ -239,9 +236,9 @@ countSnapShotStat SnapShot {..} = } data PoolParamsStats = PoolParamsStats - { ppsPoolId :: !(Stat (KeyHash 'StakePool C)) - , ppsRewardAccount :: !(Stat (Credential 'Staking C)) - , ppsOwners :: !(Stat (KeyHash 'Staking C)) + { ppsPoolId :: !(Stat (KeyHash 'StakePool)) + , ppsRewardAccount :: !(Stat (Credential 'Staking)) + , ppsOwners :: !(Stat (KeyHash 'Staking)) } instance Semigroup PoolParamsStats where @@ -267,7 +264,7 @@ instance AggregateStat PoolParamsStats where aggregateStat PoolParamsStats {..} = mempty {gsCredentialStaking = ppsRewardAccount, gsKeyHashStakePool = ppsPoolId} -countPoolParamsStats :: PoolParams C -> PoolParamsStats +countPoolParamsStats :: PoolParams -> PoolParamsStats countPoolParamsStats PoolParams {..} = PoolParamsStats { ppsPoolId = statSingleton ppId @@ -285,8 +282,8 @@ instance AggregateStat RewardUpdateStats where aggregateStat RewardUpdateStats = mempty data PoolDistrStats = PoolDistrStats - { pdsStakePoolKeyHash :: !(Stat (KeyHash 'StakePool C)) - , pdsStakePoolStakeVrf :: !(Stat (VRFVerKeyHash 'StakePoolVRF C)) + { pdsStakePoolKeyHash :: !(Stat (KeyHash 'StakePool)) + , pdsStakePoolStakeVrf :: !(Stat (VRFVerKeyHash 'StakePoolVRF)) } instance Pretty PoolDistrStats where @@ -304,7 +301,7 @@ instance AggregateStat PoolDistrStats where , gsVerKeyVRF = mapStat unVRFVerKeyHash pdsStakePoolStakeVrf } -calcPoolDistrStats :: PoolDistr C -> PoolDistrStats +calcPoolDistrStats :: PoolDistr -> PoolDistrStats calcPoolDistrStats (PoolDistr pd _tot) = PoolDistrStats { pdsStakePoolKeyHash = statMapKeys pd @@ -312,9 +309,9 @@ calcPoolDistrStats (PoolDistr pd _tot) = } data NewEpochStateStats = NewEpochStateStats - { nessPrevBlocksMade :: !(Stat (KeyHash 'StakePool C)) - , nessCurBlocksMade :: !(Stat (KeyHash 'StakePool C)) - , nessBlocksMade :: !(Stat (KeyHash 'StakePool C)) + { nessPrevBlocksMade :: !(Stat (KeyHash 'StakePool)) + , nessCurBlocksMade :: !(Stat (KeyHash 'StakePool)) + , nessBlocksMade :: !(Stat (KeyHash 'StakePool)) , nessEpochStateStats :: !EpochStateStats , nessRewardUpdate :: !RewardUpdateStats , nessPoolDistrStats :: !PoolDistrStats @@ -367,7 +364,7 @@ data EpochStateStats = EpochStateStats , essGoSnapShotStats :: !SnapShotStats , essSnapShotsStats :: !SnapShotStats , essLedgerStateStats :: !LedgerStateStats - , essNonMyopic :: !(Stat (KeyHash 'StakePool C)) + , essNonMyopic :: !(Stat (KeyHash 'StakePool)) , essAggregateStats :: !AggregateStats } @@ -409,11 +406,11 @@ countEpochStateStats EpochState {..} = } data DStateStats = DStateStats - { dssCredentialStaking :: !(Stat (Credential 'Staking C)) - , dssDelegations :: !(Stat (KeyHash 'StakePool C)) - , dssKeyHashGenesis :: !(Stat (KeyHash 'Genesis C)) - , dssKeyHashGenesisDelegate :: !(Stat (KeyHash 'GenesisDelegate C)) - , dssHashVerKeyVRF :: !(Stat (VRFVerKeyHash 'GenDelegVRF C)) + { dssCredentialStaking :: !(Stat (Credential 'Staking)) + , dssDelegations :: !(Stat (KeyHash 'StakePool)) + , dssKeyHashGenesis :: !(Stat (KeyHash 'Genesis)) + , dssKeyHashGenesisDelegate :: !(Stat (KeyHash 'GenesisDelegate)) + , dssHashVerKeyVRF :: !(Stat (VRFVerKeyHash 'GenDelegVRF)) } instance Pretty DStateStats where @@ -459,7 +456,7 @@ countDStateStats DState {..} = } data PStateStats = PStateStats - { pssKeyHashStakePool :: !(Stat (KeyHash 'StakePool C)) + { pssKeyHashStakePool :: !(Stat (KeyHash 'StakePool)) , pssPoolParamsStats :: !PoolParamsStats } @@ -519,7 +516,7 @@ countLedgerStateStats LedgerState {..} = } data TxInStats = TxInStats - { tisTxId :: !(Stat (TxId C)) + { tisTxId :: !(Stat TxId) , tisTxIx :: !(Stat TxIx) } @@ -527,7 +524,7 @@ instance Pretty TxInStats where pretty TxInStats {..} = prettyRecord "TxInStats" ["TxId" <:> tisTxId, "TxIx" <:> tisTxIx] -countTxInStats :: [TxIn C] -> TxInStats +countTxInStats :: [TxIn] -> TxInStats countTxInStats txIns = case unzip (fmap (\(TxIn txId txIx) -> (txId, txIx)) txIns) of (txIds, txIxs) -> @@ -537,16 +534,16 @@ countTxInStats txIns = } data TxOutStats = TxOutStats - { tosBootstrap :: !(Stat (BootstrapAddress C)) - , tosPaymentCredential :: !(Stat (Credential 'Payment C)) - , tosStakingCredential :: !(Stat (Credential 'Staking C)) + { tosBootstrap :: !(Stat BootstrapAddress) + , tosPaymentCredential :: !(Stat (Credential 'Payment)) + , tosStakingCredential :: !(Stat (Credential 'Staking)) , tosStakingPtr :: !(Stat Ptr) , tosNetwork :: !(Stat Network) , tosValue :: !(Stat Integer) - , tosPolicyId :: !(Stat (PolicyID C)) + , tosPolicyId :: !(Stat PolicyID) , tosAssetName :: !(Stat AssetName) , tosAssetValue :: !(Stat Integer) - , tosDataHash :: !(Stat (DataHash C)) + , tosDataHash :: !(Stat DataHash) } instance Semigroup TxOutStats where @@ -641,12 +638,12 @@ countUTxOStats (UTxO m) = } data AggregateStats = AggregateStats - { gsCredentialStaking :: !(Stat (Credential 'Staking C)) - , gsKeyHashStakePool :: !(Stat (KeyHash 'StakePool C)) - , gsKeyHashGenesis :: !(Stat (KeyHash 'Genesis C)) - , gsKeyHashGenesisDelegate :: !(Stat (KeyHash 'GenesisDelegate C)) - , gsVerKeyVRF :: !(Stat (Hash C KeyRoleVRF)) - , gsScriptHash :: !(Stat (ScriptHash C)) + { gsCredentialStaking :: !(Stat (Credential 'Staking)) + , gsKeyHashStakePool :: !(Stat (KeyHash 'StakePool)) + , gsKeyHashGenesis :: !(Stat (KeyHash 'Genesis)) + , gsKeyHashGenesisDelegate :: !(Stat (KeyHash 'GenesisDelegate)) + , gsVerKeyVRF :: !(Stat (Hash KeyRoleVRF)) + , gsScriptHash :: !(Stat ScriptHash) } instance Semigroup AggregateStats where @@ -674,26 +671,26 @@ instance Pretty AggregateStats where class AggregateStat s where aggregateStat :: s -> AggregateStats -instance AggregateStat (Stat (Credential 'Staking C)) where +instance AggregateStat (Stat (Credential 'Staking)) where aggregateStat s = mempty {gsCredentialStaking = s} -instance AggregateStat (Stat (KeyHash 'StakePool C)) where +instance AggregateStat (Stat (KeyHash 'StakePool)) where aggregateStat s = mempty {gsKeyHashStakePool = s} -instance AggregateStat (Stat (ScriptHash C)) where +instance AggregateStat (Stat ScriptHash) where aggregateStat s = mempty {gsScriptHash = s} -- Initial attempt at UTxO stats, which was mostly superseded by the above -- approach that works for the whole state data UTxOUniques = UTxOUniques - { paymentKeys :: !(Set.Set (KeyHash 'Payment C)) - , paymentScripts :: !(Set.Set (ScriptHash C)) - , stakeKeys :: !(Set.Set (KeyHash 'Staking C)) - , stakeScripts :: !(Set.Set (ScriptHash C)) + { paymentKeys :: !(Set.Set (KeyHash 'Payment)) + , paymentScripts :: !(Set.Set ScriptHash) + , stakeKeys :: !(Set.Set (KeyHash 'Staking)) + , stakeScripts :: !(Set.Set ScriptHash) , stakePtrs :: !(Set.Set Ptr) - , scripts :: !(Set.Set (ScriptHash C)) - , txIds :: !(Set.Set (TxId C)) + , scripts :: !(Set.Set ScriptHash) + , txIds :: !(Set.Set TxId) , txIxs :: !(Set.Set TxIx) } @@ -715,14 +712,14 @@ data UTxOStats' = UTxOStats' initStats :: UTxOStats' initStats = UTxOStats' 0 0 0 0 0 0 0 0 -collectStats :: ConduitT (TxIn C, TxOut CurrentEra) Void IO () +collectStats :: ConduitT (TxIn, TxOut CurrentEra) Void IO () collectStats = do (uniques, stats) <- foldlC collect (emptyUniques, initStats) lift $ reportStats uniques stats where collect :: (UTxOUniques, UTxOStats') -> - (TxIn C, TxOut CurrentEra) -> + (TxIn, TxOut CurrentEra) -> (UTxOUniques, UTxOStats') collect (u@UTxOUniques {..}, s@UTxOStats' {..}) (TxIn txId txIx, txOut) = let u' = u {txIds = Set.insert txId txIds, txIxs = Set.insert txIx txIxs} diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Vector.hs b/libs/ledger-state/src/Cardano/Ledger/State/Vector.hs index 0f6ad24e87a..f72146c1f9c 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Vector.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Vector.hs @@ -17,25 +17,24 @@ import Cardano.Ledger.Coin import Cardano.Ledger.Credential import Cardano.Ledger.Keys as Keys import Cardano.Ledger.PoolParams -import Cardano.Ledger.State.UTxO import Control.DeepSeq import Data.Map.Strict as Map -data SnapShotM c = SnapShotM - { ssStake :: !(Map (Credential 'Staking c) (CompactForm Coin)) - , ssDelegations :: !(Map (Credential 'Staking c) (KeyHash 'StakePool c)) - , ssPoolParams :: !(Map (KeyHash 'StakePool c) (PoolParams c)) +data SnapShotM = SnapShotM + { ssStake :: !(Map (Credential 'Staking) (CompactForm Coin)) + , ssDelegations :: !(Map (Credential 'Staking) (KeyHash 'StakePool)) + , ssPoolParams :: !(Map (KeyHash 'StakePool) PoolParams) } -instance NFData (SnapShotM C) where +instance NFData SnapShotM where rnf (SnapShotM s d p) = s `deepseq` d `deepseq` rnf p -data SnapShotsM c = SnapShotsM - { ssPstakeMark :: !(SnapShotM c) - , ssPstakeSet :: !(SnapShotM c) - , ssPstakeGo :: !(SnapShotM c) +data SnapShotsM = SnapShotsM + { ssPstakeMark :: !SnapShotM + , ssPstakeSet :: !SnapShotM + , ssPstakeGo :: !SnapShotM , ssFeeSS :: !Coin } -instance NFData (SnapShotsM C) where +instance NFData SnapShotsM where rnf (SnapShotsM r s g f) = r `deepseq` s `deepseq` g `deepseq` rnf f