-
Notifications
You must be signed in to change notification settings - Fork 720
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Reduce memory usage of the create-staked command
- Loading branch information
Showing
4 changed files
with
237 additions
and
6 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
47 changes: 47 additions & 0 deletions
47
cardano-cli/src/Cardano/CLI/Shelley/Run/Genesis/ListMap.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,47 @@ | ||
| module Cardano.CLI.Shelley.Run.Genesis.ListMap | ||
| ( ListMap(..) | ||
| ) where | ||
|
|
||
| import Data.Aeson (Value(..), ToJSON(..), ToJSON1(..), ToJSON2(..), ToJSONKey(..), ToJSONKeyFunction(..)) | ||
| import Data.Aeson.Types ( listEncoding, listValue ) | ||
| import Data.Aeson.Encoding ( dict ) | ||
| import Data.Eq (Eq(..)) | ||
| import Data.Function ((.), id) | ||
| import Prelude (uncurry) | ||
| import Text.Show (Show(..)) | ||
|
|
||
| import qualified Data.Aeson as J | ||
| import qualified Data.Aeson.Encoding as E | ||
| import qualified Data.Aeson.KeyMap as KM | ||
| import qualified Data.List as L | ||
| import qualified Data.Vector as V | ||
|
|
||
| newtype ListMap k v = ListMap | ||
| { unListMap :: [(k, v)] | ||
| } deriving (Eq, Show) | ||
|
|
||
| instance ToJSONKey k => ToJSON1 (ListMap k) where | ||
| liftToJSON g _ = case toJSONKey of | ||
| ToJSONKeyText f _ -> Object . KM.fromList . unListMap . mapKeyValO f g | ||
| ToJSONKeyValue f _ -> Array . V.fromList . L.map (toJSONPair f g) . unListMap | ||
|
|
||
| liftToEncoding g _ = case toJSONKey of | ||
| ToJSONKeyText _ f -> dict f g (foldrWithKey . uncurry) | ||
| ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . unListMap | ||
| where | ||
| pairEncoding f (a, b) = E.list id [f a, g b] | ||
|
|
||
| instance (ToJSON v, ToJSONKey k) => ToJSON (ListMap k v) where | ||
| toJSON = J.toJSON1 | ||
| toEncoding = J.toEncoding1 | ||
|
|
||
| foldrWithKey :: ((k, a) -> b -> b) -> b -> ListMap k a -> b | ||
| foldrWithKey f z = L.foldr f z . unListMap | ||
|
|
||
| -- | Transform the keys and values of a 'M.Map'. | ||
| mapKeyValO :: (k1 -> k2) -> (v1 -> v2) -> ListMap k1 v1 -> ListMap k2 v2 | ||
| mapKeyValO fk kv = ListMap . foldrWithKey (\(k, v) -> ((fk k, kv v):)) [] | ||
| {-# INLINE mapKeyValO #-} | ||
|
|
||
| toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value | ||
| toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,86 @@ | ||
| {-# LANGUAGE DataKinds #-} | ||
| {-# LANGUAGE DeriveGeneric #-} | ||
| {-# LANGUAGE DerivingStrategies #-} | ||
|
|
||
| module Cardano.CLI.Shelley.Run.Genesis.Types | ||
| ( OutputShelleyGenesis(..) | ||
| , ListMap(..) | ||
| , toOutputTemplate | ||
| ) where | ||
|
|
||
| import Cardano.CLI.Shelley.Run.Genesis.ListMap (ListMap(..)) | ||
| import Cardano.Ledger.Address (Addr) | ||
| import Cardano.Ledger.BaseTypes (PositiveUnitInterval, Network) | ||
| import Cardano.Ledger.Coin (Coin) | ||
| import Cardano.Ledger.Era (Era(Crypto)) | ||
| import Cardano.Ledger.Keys (KeyHash, KeyRole(Genesis), GenDelegPair) | ||
| import Cardano.Ledger.Shelley.Genesis (ShelleyGenesisStaking) | ||
| import Cardano.Ledger.Shelley.PParams ( PParams ) | ||
| import Cardano.Slotting.Slot (EpochSize(..)) | ||
| import Data.Aeson (ToJSON(..), (.=)) | ||
| import Data.Eq (Eq) | ||
| import Data.Time (NominalDiffTime, UTCTime(..)) | ||
| import Data.Word (Word32, Word64) | ||
| import GHC.Generics (Generic) | ||
| import Text.Show (Show) | ||
|
|
||
| import qualified Data.Aeson as Aeson | ||
| import qualified Data.Map as Map | ||
| import qualified Cardano.Ledger.Shelley.Genesis as Ledger | ||
|
|
||
| data OutputShelleyGenesis era = OutputShelleyGenesis | ||
| { sgSystemStart :: !UTCTime | ||
| , sgNetworkMagic :: !Word32 | ||
| , sgNetworkId :: !Network | ||
| , sgActiveSlotsCoeff :: !PositiveUnitInterval | ||
| , sgSecurityParam :: !Word64 | ||
| , sgEpochLength :: !EpochSize | ||
| , sgSlotsPerKESPeriod :: !Word64 | ||
| , sgMaxKESEvolutions :: !Word64 | ||
| , sgSlotLength :: !NominalDiffTime | ||
| , sgUpdateQuorum :: !Word64 | ||
| , sgMaxLovelaceSupply :: !Word64 | ||
| , sgProtocolParams :: !(PParams era) | ||
| , sgGenDelegs :: !(ListMap (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))) | ||
| , sgInitialFunds :: !(ListMap (Addr (Crypto era)) Coin) | ||
| , sgStaking :: !(ShelleyGenesisStaking (Crypto era)) | ||
| } | ||
| deriving stock (Eq, Show, Generic) | ||
|
|
||
| instance Era era => ToJSON (OutputShelleyGenesis era) where | ||
| toJSON sg = Aeson.object | ||
| [ "systemStart" .= sgSystemStart sg, | ||
| "networkMagic" .= sgNetworkMagic sg, | ||
| "networkId" .= sgNetworkId sg, | ||
| "activeSlotsCoeff" .= sgActiveSlotsCoeff sg, | ||
| "securityParam" .= sgSecurityParam sg, | ||
| "epochLength" .= sgEpochLength sg, | ||
| "slotsPerKESPeriod" .= sgSlotsPerKESPeriod sg, | ||
| "maxKESEvolutions" .= sgMaxKESEvolutions sg, | ||
| "slotLength" .= sgSlotLength sg, | ||
| "updateQuorum" .= sgUpdateQuorum sg, | ||
| "maxLovelaceSupply" .= sgMaxLovelaceSupply sg, | ||
| "protocolParams" .= sgProtocolParams sg, | ||
| "genDelegs" .= sgGenDelegs sg, | ||
| "initialFunds" .= sgInitialFunds sg, | ||
| "staking" .= sgStaking sg | ||
| ] | ||
|
|
||
| toOutputTemplate :: Ledger.ShelleyGenesis era -> OutputShelleyGenesis era | ||
| toOutputTemplate template = OutputShelleyGenesis | ||
| { sgSystemStart = Ledger.sgSystemStart template | ||
| , sgNetworkMagic = Ledger.sgNetworkMagic template | ||
| , sgNetworkId = Ledger.sgNetworkId template | ||
| , sgActiveSlotsCoeff = Ledger.sgActiveSlotsCoeff template | ||
| , sgSecurityParam = Ledger.sgSecurityParam template | ||
| , sgEpochLength = Ledger.sgEpochLength template | ||
| , sgSlotsPerKESPeriod = Ledger.sgSlotsPerKESPeriod template | ||
| , sgMaxKESEvolutions = Ledger.sgMaxKESEvolutions template | ||
| , sgSlotLength = Ledger.sgSlotLength template | ||
| , sgUpdateQuorum = Ledger.sgUpdateQuorum template | ||
| , sgMaxLovelaceSupply = Ledger.sgMaxLovelaceSupply template | ||
| , sgProtocolParams = Ledger.sgProtocolParams template | ||
| , sgGenDelegs = ListMap (Map.toList (Ledger.sgGenDelegs template)) | ||
| , sgInitialFunds = ListMap (Map.toList (Ledger.sgInitialFunds template)) | ||
| , sgStaking = Ledger.sgStaking template | ||
| } |