Use base monad

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

@@ -88,6 +88,8 @@ library
     microlens-th,
     mtl,
     non-integer,
+    stm,
+    transformers,
     cs-ledger,
     cardano-binary,
     cardano-crypto-class,

shelley/chain-and-ledger/executable-spec/src/BaseTypes.hs

@@ -20,18 +20,24 @@ module BaseTypes
   , mkNonce
   , (⭒)
   , (==>)
+    -- * STS Base
+  , Globals (..)
+  , ShelleyBase
   ) where
 
 
 import           Cardano.Binary (ToCBOR (toCBOR), encodeListLen)
 import           Cardano.Crypto.Hash
 import           Cardano.Prelude (NoUnexpectedThunks (..))
+import           Cardano.Slotting.EpochInfo
 import           Data.Coerce (coerce)
 import qualified Data.Fixed as FP (Fixed, HasResolution, resolution)
 import           Data.Ratio (denominator, numerator, (%))
 import           Data.Word (Word64, Word8)
 import           GHC.Generics (Generic)
 import           Numeric.Natural (Natural)
+import           Control.Monad.Trans.Reader
+import           Control.Monad.STM
 
 data E34
 
@@ -111,3 +117,14 @@ newtype Seed = Seed (Hash SHA256 Seed)
 (==>) :: Bool -> Bool -> Bool
 a ==> b = not a || b
 infix 1 ==>
+
+--------------------------------------------------------------------------------
+-- Base monad for all STS systems
+--------------------------------------------------------------------------------
+
+data Globals = Globals
+  { epochInfo :: EpochInfo ShelleyBase
+  , slotsPerKESPeriod :: Word64
+  }
+
+type ShelleyBase = ReaderT Globals STM

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

@@ -17,7 +17,7 @@ import qualified Cardano.Crypto.DSIGN as DSIGN
 import Cardano.Ledger.Shelley.Crypto
 import Control.Arrow (left, right)
 import Control.Monad.Except
-import Control.State.Transition (TRC (..), applySTS)
+import Control.State.Transition.Extended (TRC (..), applySTS)
 import Ledger.Core (Relation (..))
 import qualified LedgerState
 import qualified STS.Bbody as STS

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

@@ -100,7 +100,8 @@ import           Address (mkRwdAcnt)
 import           Cardano.Ledger.Shelley.Crypto
 import           Cardano.Prelude (NoUnexpectedThunks (..))
 import           Coin (Coin (..))
-import           Data.Foldable (toList)
+import           Control.Monad.Trans.Reader (asks)
+import           Data.Foldable (asum, toList)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
@@ -134,8 +135,8 @@ import           Delegation.Certificates (DCert (..), PoolDistr (..), StakeCreds
                      StakePools (..), cwitness, decayKey, refund)
 import           Delegation.PoolParams (poolSpec)
 
-import           BaseTypes (UnitInterval, intervalValue, mkUnitInterval)
-
+import           BaseTypes (ShelleyBase, Globals(..), UnitInterval, intervalValue, mkUnitInterval)
+import           Cardano.Slotting.EpochInfo
 import           Ledger.Core (dom, (∪), (∪+), (⋪), (▷), (◁))
 
 -- | Representation of a list of pairs of key pairs, e.g., pay and stake keys
@@ -451,30 +452,34 @@ decayedKey
   -> StakeCreds crypto
   -> SlotNo
   -> DCert crypto
-  -> Coin
+  -> ShelleyBase Coin
 decayedKey pp stk@(StakeCreds stkcreds) cslot cert =
     case cert of
       DeRegKey key ->
           if Map.notMember key stkcreds
-          then 0
-          else let created'      = stkcreds Map.! key in
-               let start         = max (firstSlotNo $ epochFromSlotNo cslot) created' in
-               let dval          = pp ^. keyDeposit in
-               let dmin          = pp ^. keyMinRefund in
-               let lambda        = pp ^. keyDecayRate in
-               let epochRefund   = keyRefund dval dmin lambda stk start cert in
-               let currentRefund = keyRefund dval dmin lambda stk cslot cert in
-               epochRefund - currentRefund
-      _ -> 0
+          then pure 0
+          else do
+            let created'      = stkcreds Map.! key
+            start <- do
+              ei <- asks epochInfo
+              fs <- epochInfoFirst ei =<< epochInfoEpoch ei cslot
+              pure $ max fs created'
+            let dval          = pp ^. keyDeposit
+                dmin          = pp ^. keyMinRefund
+                lambda        = pp ^. keyDecayRate
+                epochRefund   = keyRefund dval dmin lambda stk start cert
+                currentRefund = keyRefund dval dmin lambda stk cslot cert
+            pure $ epochRefund - currentRefund
+      _ -> pure 0
 
 -- | Decayed deposit portions
 decayedTx
   :: PParams
   -> StakeCreds crypto
   -> TxBody crypto
-  -> Coin
+  -> ShelleyBase Coin
 decayedTx pp stk tx =
-    sum [decayedKey pp stk (tx ^. ttl) c | c@(DeRegKey _) <- toList $ tx ^. certs]
+    asum [decayedKey pp stk (tx ^. ttl) c | c@(DeRegKey _) <- toList $ tx ^. certs]
 
 -- |Compute the lovelace which are destroyed by the transaction
 consumed
@@ -856,12 +861,14 @@ applyRUpd ru (EpochState as ss ls pp) = EpochState as' ss ls' pp
 
 -- | Create a reward update
 createRUpd
-  :: BlocksMade crypto
+  :: EpochNo
+  -> BlocksMade crypto
   -> EpochState crypto
-  -> RewardUpdate crypto
-createRUpd b@(BlocksMade b') (EpochState acnt ss ls pp) =
-  RewardUpdate (Coin $ deltaT1 + deltaT2) (-deltaR') rs' (-(_feeSS ss)) registered
-  where Coin reserves' = _reserves acnt
+  -> ShelleyBase (RewardUpdate crypto)
+createRUpd e b@(BlocksMade b') (EpochState acnt ss ls pp) = do
+    ei <- asks epochInfo
+    slotsPerEpoch <- epochInfoSize ei e
+    let Coin reserves' = _reserves acnt
 
         ds = _dstate $ _delegationState ls
         rewards' = _rewards ds
@@ -891,6 +898,7 @@ createRUpd b@(BlocksMade b') (EpochState acnt ss ls pp) =
 
         blocksMade = fromIntegral $ Map.foldr (+) 0 b' :: Integer
         expectedBlocks = intervalValue (_activeSlotCoeff pp) * fromIntegral slotsPerEpoch
+    pure $ RewardUpdate (Coin $ deltaT1 + deltaT2) (-deltaR') rs' (-(_feeSS ss)) registered
 
 -- | Overlay schedule
 -- This is just a very simple round-robin, evenly spaced schedule.
@@ -899,16 +907,19 @@ overlaySchedule
   :: EpochNo
   -> Set (GenKeyHash crypto)
   -> PParams
-  -> Map SlotNo (Maybe (GenKeyHash crypto))
-overlaySchedule e gkeys pp = Map.union active inactive
-  where
+  -> ShelleyBase (Map SlotNo (Maybe (GenKeyHash crypto)))
+overlaySchedule e gkeys pp = do
+  ei <- asks epochInfo
+  slotsPerEpoch <- epochInfoSize ei e
+  firstSlotNo <- epochInfoFirst ei e
+  let
     numActive = dval * fromIntegral slotsPerEpoch
     dval = intervalValue $ pp ^. d
     dInv = 1 / dval
     asc = intervalValue $ pp ^. activeSlotCoeff
 
     toRelativeSlotNo x = (Duration . floor) (dInv * fromInteger x)
-    toSlotNo x = firstSlotNo e +* toRelativeSlotNo x
+    toSlotNo x = firstSlotNo +* toRelativeSlotNo x
 
     genesisSlots = [ toSlotNo x | x <-[0..(floor numActive)] ]
 
@@ -924,6 +935,7 @@ overlaySchedule e gkeys pp = Map.union active inactive
       Map.fromList $ fmap
         (\x -> (snd x, Nothing))
         (filter (not . fst) unassignedSched)
+  pure $ Map.union active inactive
 
 -- | Update new epoch state
 updateNES

shelley/chain-and-ledger/executable-spec/src/OCert.hs

@@ -22,8 +22,10 @@ import           GHC.Generics (Generic)
 import           Cardano.Ledger.Shelley.Crypto
 import           Keys (KeyHash, Sig, VKey, VKeyES)
 import           Slot (SlotNo (..))
-
+import           BaseTypes
 import           Numeric.Natural (Natural)
+import           Control.Monad.Trans.Reader (asks)
+import           Data.Functor ((<&>))
 
 data OCertEnv crypto = OCertEnv
   { ocertEnvStPools :: Set (KeyHash crypto)
@@ -83,8 +85,6 @@ instance
       <*> fromCBOR
       <*> fromCBOR
 
-slotsPerKESPeriod :: Natural
-slotsPerKESPeriod = 90
-
-kesPeriod :: SlotNo -> KESPeriod
-kesPeriod (SlotNo s) = KESPeriod $ s `div` slotsPerKESPeriod
+kesPeriod :: SlotNo -> ShelleyBase KESPeriod
+kesPeriod (SlotNo s) = asks slotsPerKESPeriod <&> \spkp ->
+  KESPeriod . fromIntegral $ s `div` spkp

shelley/chain-and-ledger/executable-spec/src/STS/Avup.hs

@@ -11,7 +11,7 @@ where
 
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-
+import           BaseTypes
 import           BlockChain
 import           Keys
 import           Slot
@@ -37,6 +37,7 @@ instance STS (AVUP crypto) where
     = AVUPState crypto
   type Signal (AVUP crypto) = AVUpdate crypto
   type Environment (AVUP crypto) = AVUPEnv crypto
+  type BaseM (AVUP crypto) = ShelleyBase
   data PredicateFailure (AVUP crypto)
     = EmptyAVUP
     | NonEmptyAVUP

shelley/chain-and-ledger/executable-spec/src/STS/Bbody.hs

@@ -18,7 +18,7 @@ where
 import           Data.Set (Set)
 
 import           Control.State.Transition
-
+import           BaseTypes
 import           BlockChain
 import           Coin (Coin)
 import           EpochBoundary
@@ -58,6 +58,8 @@ instance
 
   type Environment (BBODY crypto) = BbodyEnv
 
+  type BaseM (BBODY crypto) = ShelleyBase
+
   data PredicateFailure (BBODY crypto)
     = WrongBlockBodySizeBBODY
     | InvalidBodyHashBBODY

shelley/chain-and-ledger/executable-spec/src/STS/Bhead.hs

@@ -13,7 +13,7 @@ module STS.Bhead
 where
 
 import           Data.Set (Set)
-
+import           BaseTypes
 import           BlockChain
 import           Keys
 import           LedgerState
@@ -23,6 +23,7 @@ import           STS.NewEpoch
 import           STS.Rupd
 import           Cardano.Ledger.Shelley.Crypto
 import           Control.State.Transition
+import           Control.Monad.Trans.Reader (asks)
 
 data BHEAD crypto
 
@@ -37,6 +38,7 @@ instance Crypto crypto
   type Signal (BHEAD crypto)
     = BHeader crypto
   type Environment (BHEAD crypto) = BheadEnv crypto
+  type BaseM (BHEAD crypto) = ShelleyBase
   data PredicateFailure (BHEAD crypto)
     = HeaderSizeTooLargeBHEAD
     | BlockSizeTooLargeBHEAD
@@ -60,8 +62,12 @@ bheadTransition = do
   fromIntegral (bHeaderSize bh) < _maxBHSize pp ?! HeaderSizeTooLargeBHEAD
   fromIntegral (hBbsize bhb) < _maxBBSize pp ?! BlockSizeTooLargeBHEAD
 
+  epoch <- liftSTS $ do
+    ei <- asks epochInfo
+    epochInfoEpoch ei slot
+
   nes' <- trans @(NEWEPOCH crypto)
-    $ TRC (NewEpochEnv slot gkeys, nes, epochFromSlotNo slot)
+    $ TRC (NewEpochEnv slot gkeys, nes, epoch)
 
   ru' <- trans @(RUPD crypto) $ TRC (RupdEnv bprev es, nesRu nes', slot)
   let nes'' = nes' { nesRu = ru' }

shelley/chain-and-ledger/executable-spec/src/STS/Chain.hs

@@ -65,6 +65,7 @@ instance
     = Block crypto
 
   type Environment (CHAIN crypto) = SlotNo
+  type BaseM (CHAIN crypto) = ShelleyBase
 
   data PredicateFailure (CHAIN crypto)
     = BbodyFailure (PredicateFailure (BBODY crypto))

shelley/chain-and-ledger/executable-spec/src/STS/Deleg.hs

@@ -10,7 +10,7 @@ where
 
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
-
+import           BaseTypes
 import           BlockChain (slotsPrior)
 import           Coin (Coin (..))
 import           Delegation.Certificates
@@ -20,6 +20,7 @@ import           LedgerState
 import           Slot
 import           TxData
 
+import           Control.Monad.Trans.Reader (asks)
 import           Cardano.Ledger.Shelley.Crypto
 import           Control.State.Transition
 import           Control.State.Transition.Generator (HasTrace, envGen, sigGen)
@@ -41,6 +42,7 @@ instance STS (DELEG crypto)
   type State (DELEG crypto) = DState crypto
   type Signal (DELEG crypto) = DCert crypto
   type Environment (DELEG crypto) = DelegEnv
+  type BaseM (DELEG crypto) = ShelleyBase
   data PredicateFailure (DELEG crypto)
     = StakeKeyAlreadyRegisteredDELEG
     | StakeKeyNotRegisteredDELEG
@@ -102,8 +104,11 @@ delegationTransition = do
     InstantaneousRewards credCoinMap -> do
       let combinedMap = Map.union credCoinMap (_irwd ds)
           requiredForRewards = foldl (+) (Coin 0) (range combinedMap)
-          EpochNo currEpoch = epochFromSlotNo slot_
-      slot_ < (firstSlotNo $ EpochNo (currEpoch + 1)) *- slotsPrior
+      firstSlot <- liftSTS $ do
+        ei <- asks epochInfo
+        EpochNo currEpoch <- epochInfoEpoch ei slot_
+        epochInfoFirst ei $ EpochNo (currEpoch + 1)
+      slot_ < firstSlot *- slotsPrior
         ?! MIRCertificateTooLateinEpochDELEG
       requiredForRewards <= reserves_ ?! InsufficientForInstantaneousRewardsDELEG
 
@@ -114,7 +119,7 @@ delegationTransition = do
       pure ds
 
 
-instance Crypto crypto
-  => HasTrace (DELEG crypto) where
-  envGen _ = undefined :: Gen DelegEnv
-  sigGen _ _ = undefined :: Gen (DCert crypto)
+-- instance Crypto crypto
+--   => HasTrace (DELEG crypto) where
+--   envGen _ = undefined :: Gen DelegEnv
+--   sigGen _ _ = undefined :: Gen (DCert crypto)

shelley/chain-and-ledger/executable-spec/src/STS/Delegs.hs

@@ -14,7 +14,7 @@ where
 import qualified Data.Set as Set
 
 import           Data.Sequence (Seq (..))
-
+import           BaseTypes
 import           Coin (Coin)
 import           Delegation.Certificates
 import           LedgerState
@@ -52,6 +52,7 @@ instance
   type State (DELEGS crypto) = DPState crypto
   type Signal (DELEGS crypto) = Seq (DCert crypto)
   type Environment (DELEGS crypto) = DelegsEnv crypto
+  type BaseM (DELEGS crypto) = ShelleyBase
   data PredicateFailure (DELEGS crypto)
     = DelegateeNotRegisteredDELEG
     | WithrawalsNotInRewardsDELEGS
@@ -104,7 +105,7 @@ instance
   wrapFailed = DelplFailure
 
 
-instance Crypto crypto
-  => HasTrace (DELEGS crypto) where
-  envGen _ = undefined :: Gen (DelegsEnv crypto)
-  sigGen _ _ = undefined :: Gen (Seq (DCert crypto))
+-- instance Crypto crypto
+--   => HasTrace (DELEGS crypto) where
+--   envGen _ = undefined :: Gen (DelegsEnv crypto)
+--   sigGen _ _ = undefined :: Gen (Seq (DCert crypto))

shelley/chain-and-ledger/executable-spec/src/STS/Delpl.hs

@@ -11,6 +11,7 @@ module STS.Delpl
   )
 where
 
+import           BaseTypes
 import           Coin (Coin)
 import           Delegation.Certificates
 import           LedgerState
@@ -41,6 +42,7 @@ instance
   type State (DELPL crypto)       = DPState crypto
   type Signal (DELPL crypto)      = DCert crypto
   type Environment (DELPL crypto) = DelplEnv
+  type BaseM (DELPL crypto) = ShelleyBase
   data PredicateFailure (DELPL crypto)
     = PoolFailure (PredicateFailure (POOL crypto))
     | DelegFailure (PredicateFailure (DELEG crypto))