Move 'OverlaySchedule' into its own module.

'LedgerState' is already a giant grab-bag of functionality. This is a
good excuse to extract some of it.

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

@@ -35,6 +35,7 @@ library
  Shelley.Spec.Ledger.MetaData
  Shelley.Spec.Ledger.OCert
  Shelley.Spec.Ledger.Orphans
+ Shelley.Spec.Ledger.OverlaySchedule
  Shelley.Spec.Ledger.PParams
  Shelley.Spec.Ledger.Rewards
  Shelley.Spec.Ledger.Scripts

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Protocol.hs

@@ -46,13 +46,15 @@ import Shelley.Spec.Ledger.Keys (GenDelegs)
 import Shelley.Spec.Ledger.LedgerState
  ( EpochState (..),
  NewEpochState (..),
- OverlaySchedule,
  getGKeys,
  _delegationState,
  _dstate,
  _genDelegs,
  )
 import Shelley.Spec.Ledger.OCert (OCertSignable)
+import Shelley.Spec.Ledger.OverlaySchedule
+ ( OverlaySchedule,
+ )
 import Shelley.Spec.Ledger.PParams (PParams)
 import qualified Shelley.Spec.Ledger.STS.Prtcl as STS.Prtcl
 import Shelley.Spec.Ledger.STS.Tick (TICK, TickEnv (..))

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Types.hs

@@ -66,19 +66,19 @@ import Shelley.Spec.Ledger.LedgerState as X
  LedgerState (..),
  NewEpochEnv (..),
  NewEpochState (..),
- OBftSlot (..),
  PState (..),
  RewardUpdate (..),
  UTxOState (..),
  WitHashes (..),
  )
 import Shelley.Spec.Ledger.OCert as X (OCert (..))
+import Shelley.Spec.Ledger.OverlaySchedule as X
+ ( OBftSlot (..),
+ )
 import Shelley.Spec.Ledger.PParams as X
  ( PParams,
  PParams' (..),
- )
-import Shelley.Spec.Ledger.PParams as X
- ( ProposedPPUpdates (..),
+ ProposedPPUpdates (..),
  Update (..),
  )
 import Shelley.Spec.Ledger.Rewards as X

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs

@@ -28,6 +28,7 @@ import Shelley.Spec.Ledger.BlockChain
 import Shelley.Spec.Ledger.Crypto
 import Shelley.Spec.Ledger.Keys
 import qualified Shelley.Spec.Ledger.LedgerState as LedgerState
+import Shelley.Spec.Ledger.OverlaySchedule (overlaySlots)
 import Shelley.Spec.Ledger.PParams (PParams)
 import qualified Shelley.Spec.Ledger.STS.Bbody as STS
 import qualified Shelley.Spec.Ledger.STS.Chain as STS
@@ -68,7 +69,7 @@ mkBbodyEnv
  LedgerState.nesEs
  } =
  STS.BbodyEnv
- { STS.bbodySlots = LedgerState.overlaySlots nesOsched,
+ { STS.bbodySlots = overlaySlots nesOsched,
  STS.bbodyPp = LedgerState.esPp nesEs,
  STS.bbodyAccount = LedgerState.esAccountState nesEs
  }

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs

@@ -35,9 +35,9 @@ import Shelley.Spec.Ledger.LedgerState
  LedgerState (..),
  NewEpochState (..),
  UTxOState (..),
- lookupInOverlaySchedule,
  stakeDistr,
  )
+import Shelley.Spec.Ledger.OverlaySchedule (lookupInOverlaySchedule)
 import Shelley.Spec.Ledger.Rewards
  ( NonMyopic (..),
  StakeShare (..),

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs

@@ -33,7 +33,6 @@ module Shelley.Spec.Ledger.LedgerState
  Ix,
  KeyPairs,
  LedgerState (..),
- OBftSlot (..),
  PPUPState (..),
  PState (..),
  RewardAccounts,
@@ -88,39 +87,19 @@ module Shelley.Spec.Ledger.LedgerState
  NewEpochEnv (..),
  getGKeys,
  updateNES,
-
- -- * Overlay schedule
- OverlaySchedule,
- OverlaySlots,
- compactOverlaySchedule,
- decompactOverlaySchedule,
- emptyOverlaySchedule,
- isOverlaySlot,
- lookupInOverlaySchedule,
- overlaySchedule,
- overlayScheduleHelper,
- overlayScheduleIsEmpty,
- overlayScheduleToMap,
- overlaySlots,
  )
 where
 
 import Cardano.Binary
  ( FromCBOR (..),
  ToCBOR (..),
- TokenType (TypeNull),
- decodeNull,
  encodeListLen,
- encodeNull,
- peekTokenType,
  )
 import Cardano.Prelude (NFData, NoUnexpectedThunks (..))
 import Control.Iterate.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁))
 import Control.Monad.Trans.Reader (asks)
 import qualified Data.ByteString.Lazy as BSL (length)
 import Data.Foldable (toList)
-import Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as NonEmpty
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
@@ -136,11 +115,9 @@ import Shelley.Spec.Ledger.Address.Bootstrap
  verifyBootstrapWit,
  )
 import Shelley.Spec.Ledger.BaseTypes
- ( ActiveSlotCoeff,
- Globals (..),
+ ( Globals (..),
  ShelleyBase,
  StrictMaybe (..),
- UnitInterval,
  activeSlotVal,
  intervalValue,
  unitIntervalToRational,
@@ -177,6 +154,7 @@ import Shelley.Spec.Ledger.Keys
  VKey,
  asWitness,
  )
+import Shelley.Spec.Ledger.OverlaySchedule
 import Shelley.Spec.Ledger.PParams
  ( PParams,
  PParams' (..),
@@ -194,13 +172,9 @@ import Shelley.Spec.Ledger.Rewards
  )
 import Shelley.Spec.Ledger.Serialization (decodeRecordNamed, mapFromCBOR, mapToCBOR)
 import Shelley.Spec.Ledger.Slot
- ( Duration (..),
- EpochNo (..),
+ ( EpochNo (..),
  EpochSize,
  SlotNo (..),
- epochInfoFirst,
- epochInfoSize,
- (+*),
  )
 import Shelley.Spec.Ledger.Tx
  ( Tx (..),
@@ -561,33 +535,6 @@ instance Crypto crypto => FromCBOR (UTxOState crypto) where
  us <- fromCBOR
  pure $ UTxOState ut dp fs us
 
-data OBftSlot crypto
- = NonActiveSlot
- | ActiveSlot !(KeyHash 'Genesis crypto)
- deriving (Show, Eq, Ord, Generic)
-
-instance
- Crypto crypto =>
- ToCBOR (OBftSlot crypto)
- where
- toCBOR NonActiveSlot = encodeNull
- toCBOR (ActiveSlot k) = toCBOR k
-
-instance
- Crypto crypto =>
- FromCBOR (OBftSlot crypto)
- where
- fromCBOR = do
- peekTokenType >>= \case
- TypeNull -> do
- decodeNull
- pure NonActiveSlot
- _ -> ActiveSlot <$> fromCBOR
-
-instance NoUnexpectedThunks (OBftSlot crypto)
-
-instance NFData (OBftSlot crypto)
-
 -- | New Epoch state and environment
 data NewEpochState crypto = NewEpochState
  { -- | Last epoch
@@ -1028,115 +975,3 @@ updateNES
  bcur
  ls =
  NewEpochState eL bprev bcur (EpochState acnt ss ls pr pp nm) ru pd osched
-
-newtype OverlaySchedule crypto = OverlaySchedule (Map SlotNo (OBftSlot crypto))
- deriving stock (Show, Eq)
- deriving newtype (NoUnexpectedThunks, NFData)
-
-emptyOverlaySchedule :: OverlaySchedule crypto
-emptyOverlaySchedule = OverlaySchedule Map.empty
-
-lookupInOverlaySchedule ::
- SlotNo ->
- OverlaySchedule crypto ->
- Maybe (OBftSlot crypto)
-lookupInOverlaySchedule slot (OverlaySchedule oSched) = Map.lookup slot oSched
-
-overlayScheduleIsEmpty :: OverlaySchedule crypto -> Bool
-overlayScheduleIsEmpty (OverlaySchedule oSched) = Map.null oSched
-
--- | Overlay schedule
--- This is just a very simple round-robin, evenly spaced schedule.
-overlaySchedule ::
- EpochNo ->
- Set (KeyHash 'Genesis crypto) ->
- PParams ->
- ShelleyBase (OverlaySchedule crypto)
-overlaySchedule e gkeys pp = do
- ei <- asks epochInfo
- slotsPerEpoch <- epochInfoSize ei e
- firstSlotNo <- epochInfoFirst ei e
- asc <- asks activeSlotCoeff
- pure $ overlayScheduleHelper slotsPerEpoch firstSlotNo gkeys (_d pp) asc
-
-overlayScheduleHelper ::
- EpochSize ->
- -- | First slot of the epoch
- SlotNo ->
- Set (KeyHash 'Genesis crypto) ->
- -- | Decentralization parameter @d@
- UnitInterval ->
- ActiveSlotCoeff ->
- OverlaySchedule crypto
-overlayScheduleHelper slotsPerEpoch firstSlotNo gkeys d asc
- | dval == 0 =
- OverlaySchedule $ Map.empty
- | otherwise =
- OverlaySchedule $ Map.union active inactive
- where
- dval = intervalValue d
- numActive = dval * fromIntegral slotsPerEpoch
- dInv = 1 / dval
- ascValue = (intervalValue . activeSlotVal) asc
- toRelativeSlotNo x = (Duration . floor) (dInv * fromInteger x)
- toSlotNo x = firstSlotNo +* toRelativeSlotNo x
- genesisSlots = [toSlotNo x | x <- [0 .. (floor numActive - 1)]]
- numInactivePerActive = floor (1 / ascValue) - 1
- activitySchedule = cycle (True : replicate numInactivePerActive False)
- unassignedSched = zip activitySchedule genesisSlots
- genesisCycle = if Set.null gkeys then [] else cycle (Set.toList gkeys)
- active =
- Map.fromList $
- fmap
- (\(gk, (_, s)) -> (s, ActiveSlot gk))
- (zip genesisCycle (filter fst unassignedSched))
- inactive =
- Map.fromList $
- fmap
- (\x -> (snd x, NonActiveSlot))
- (filter (not . fst) unassignedSched)
-
-overlayScheduleToMap :: OverlaySchedule crypto -> Map SlotNo (OBftSlot crypto)
-overlayScheduleToMap (OverlaySchedule oSched) = oSched
-
--- | Convert the overlay schedule to a representation that is more compact
--- when serialised to a bytestring, but less efficient for lookups.
---
--- Each genesis key hash will only be stored once, instead of each time it is
--- assigned to a slot.
-compactOverlaySchedule ::
- OverlaySchedule crypto ->
- Map (OBftSlot crypto) (NonEmpty SlotNo)
-compactOverlaySchedule (OverlaySchedule oSched) =
- Map.foldrWithKey'
- ( \slot obftSlot ->
- Map.insertWith (<>) obftSlot (pure slot)
- )
- Map.empty
- oSched
-
--- | Inverse of 'compactOverlaySchedule'
-decompactOverlaySchedule ::
- Map (OBftSlot crypto) (NonEmpty SlotNo) ->
- OverlaySchedule crypto
-decompactOverlaySchedule compact =
- OverlaySchedule $
- Map.fromList
- [ (slot, obftSlot)
- | (obftSlot, slots) <- Map.toList compact,
- slot <- NonEmpty.toList slots
- ]
-
-instance Crypto crypto => ToCBOR (OverlaySchedule crypto) where
- toCBOR = toCBOR . compactOverlaySchedule
-
-instance Crypto crypto => FromCBOR (OverlaySchedule crypto) where
- fromCBOR = decompactOverlaySchedule <$> fromCBOR
-
-newtype OverlaySlots = OverlaySlots (Set SlotNo)
-
-overlaySlots :: OverlaySchedule crypto -> OverlaySlots
-overlaySlots (OverlaySchedule oSched) = OverlaySlots (Map.keysSet oSched)
-
-isOverlaySlot :: SlotNo -> OverlaySlots -> Bool
-isOverlaySlot slot (OverlaySlots oslots) = Set.member slot oslots