Introduce Canonical to ouroboros-consensus-shelley[-test]

Co-authored-by: Nick Frisby <nick.frisby@iohk.io> Co-authored-by: Damian Nadales <damian.nadales@iohk.io> Co-authored-by: Joris Dral <joris@well-typed.com>
IntersectMBO · Jan 30, 2023 · c4d8dce · c4d8dce
1 parent d7c1c6c
commit c4d8dce
Show file tree

Hide file tree

Showing 11 changed files with 48 additions and 50 deletions.
diff --git a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs
@@ -182,7 +182,7 @@ instance CanMock proto era=> Arbitrary (ShelleyTip proto era) where
 instance Arbitrary ShelleyTransition where
   arbitrary = ShelleyTransitionInfo <$> arbitrary
 
-instance CanMock proto era => Arbitrary (LedgerState (ShelleyBlock proto era)) where
+instance CanMock proto era => Arbitrary (LedgerState (ShelleyBlock proto era) Canonical) where
   arbitrary = ShelleyLedgerState
     <$> arbitrary
     <*> arbitrary

diff --git a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs
@@ -80,7 +80,7 @@ instance HashAlgorithm h => TxGen (ShelleyBlock (TPraos (MockCrypto h)) (MockShe
 
       go :: [GenTx (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h))]  -- ^ Accumulator
          -> Integer  -- ^ Number of txs to still produce
-         -> TickedLedgerState (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h))
+         -> TickedLedgerState (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h)) Canonical
          -> Gen [GenTx (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h))]
       go acc 0 _  = return (reverse acc)
       go acc n st = do
@@ -96,7 +96,7 @@ genTx
   :: forall h. HashAlgorithm h
   => TopLevelConfig (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h))
   -> SlotNo
-  -> TickedLedgerState (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h))
+  -> TickedLedgerState (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h)) Canonical
   -> Gen.GenEnv (MockShelley h)
   -> Gen (Maybe (GenTx (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h))))
 genTx _cfg slotNo TickedShelleyLedgerState { tickedShelleyLedgerState } genEnv =

diff --git a/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs b/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs
@@ -362,7 +362,7 @@ prop_simple_real_tpraos_convergence TestSetup
             DoGeneratePPUs    -> True
             DoNotGeneratePPUs -> False
 
-        finalLedgers :: [(NodeId, LedgerState (ShelleyBlock Proto Era))]
+        finalLedgers :: [(NodeId, LedgerState (ShelleyBlock Proto Era) Canonical)]
         finalLedgers =
             Map.toList $ nodeOutputFinalLedger <$> testOutputNodes testOutput
 

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs
@@ -48,12 +48,12 @@ forgeShelleyBlock ::
   => HotKey (EraCrypto era) m
   -> CanBeLeader proto
   -> TopLevelConfig (ShelleyBlock proto era)
-  -> TxLimits.Overrides (ShelleyBlock proto era)  -- ^ How to override max tx
-                                                  --   capacity defined by ledger
-  -> BlockNo                                      -- ^ Current block number
-  -> SlotNo                                       -- ^ Current slot number
-  -> TickedLedgerState (ShelleyBlock proto era)   -- ^ Current ledger
-  -> [Validated (GenTx (ShelleyBlock proto era))] -- ^ Txs to add in the block
+  -> TxLimits.Overrides (ShelleyBlock proto era)          -- ^ How to override max tx
+                                                          --   capacity defined by ledger
+  -> BlockNo                                              -- ^ Current block number
+  -> SlotNo                                               -- ^ Current slot number
+  -> TickedLedgerState (ShelleyBlock proto era) Canonical -- ^ Current ledger
+  -> [Validated (GenTx (ShelleyBlock proto era))]         -- ^ Txs to add in the block
   -> IsLeader proto
   -> m (ShelleyBlock proto era)
 forgeShelleyBlock

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs
@@ -106,7 +106,7 @@ data UpdateState c = UpdateState {
 protocolUpdates ::
        forall era proto. ShelleyBasedEra era
     => SL.ShelleyGenesis era
-    -> LedgerState (ShelleyBlock proto era)
+    -> LedgerState (ShelleyBlock proto era) Canonical
     -> [ProtocolUpdate era]
 protocolUpdates genesis st = [
       ProtocolUpdate {

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs
@@ -24,6 +24,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger (
   , ShelleyTip (..)
   , ShelleyTransition (..)
   , Ticked (..)
+  , Ticked1 (..)
   , castShelleyTip
   , shelleyLedgerTipPoint
   , shelleyTipToPoint
@@ -74,7 +75,7 @@ import           Ouroboros.Consensus.HardFork.History.Util
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.CommonProtocolParams
-import           Ouroboros.Consensus.Ledger.Extended
+import           Ouroboros.Consensus.Ticked
 import           Ouroboros.Consensus.Util ((..:))
 import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin,
                      encodeWithOrigin)
@@ -192,16 +193,16 @@ castShelleyTip (ShelleyTip sn bn hh) = ShelleyTip {
     , shelleyTipHash    = coerce hh
     }
 
-data instance LedgerState (ShelleyBlock proto era) = ShelleyLedgerState {
+data instance LedgerState (ShelleyBlock proto era) mk = ShelleyLedgerState {
       shelleyLedgerTip        :: !(WithOrigin (ShelleyTip proto era))
     , shelleyLedgerState      :: !(SL.NewEpochState era)
     , shelleyLedgerTransition :: !ShelleyTransition
     }
   deriving (Generic)
 
-deriving instance ShelleyBasedEra era => Show     (LedgerState (ShelleyBlock proto era))
-deriving instance ShelleyBasedEra era => Eq       (LedgerState (ShelleyBlock proto era))
-deriving instance ShelleyBasedEra era => NoThunks (LedgerState (ShelleyBlock proto era))
+deriving instance ShelleyBasedEra era => Show     (LedgerState (ShelleyBlock proto era) mk)
+deriving instance ShelleyBasedEra era => Eq       (LedgerState (ShelleyBlock proto era) mk)
+deriving instance ShelleyBasedEra era => NoThunks (LedgerState (ShelleyBlock proto era) mk)
 
 -- | Information required to determine the hard fork point from Shelley to the
 -- next ledger
@@ -227,7 +228,7 @@ newtype ShelleyTransition = ShelleyTransitionInfo {
   deriving stock   (Eq, Show, Generic)
   deriving newtype (NoThunks)
 
-shelleyLedgerTipPoint :: LedgerState (ShelleyBlock proto era) -> Point (ShelleyBlock proto era)
+shelleyLedgerTipPoint :: LedgerState (ShelleyBlock proto era) mk -> Point (ShelleyBlock proto era)
 shelleyLedgerTipPoint = shelleyTipToPoint . shelleyLedgerTip
 
 instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era)
@@ -236,18 +237,18 @@ instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era)
   GetTip
 -------------------------------------------------------------------------------}
 
-instance GetTip (LedgerState (ShelleyBlock proto era)) where
+instance GetTip (LedgerState (ShelleyBlock proto era) mk) where
   getTip = castPoint . shelleyLedgerTipPoint
 
-instance GetTip (Ticked (LedgerState (ShelleyBlock proto era))) where
-  getTip = castPoint . untickedShelleyLedgerTipPoint
+instance GetTip (Ticked1 (LedgerState (ShelleyBlock proto era)) mk) where
+  getTip = castPoint . shelleyTipToPoint . untickedShelleyLedgerTip
 
 {-------------------------------------------------------------------------------
   Ticking
 -------------------------------------------------------------------------------}
 
 -- | Ticking only affects the state itself
-data instance Ticked (LedgerState (ShelleyBlock proto era)) = TickedShelleyLedgerState {
+data instance Ticked1 (LedgerState (ShelleyBlock proto era)) mk = TickedShelleyLedgerState {
       untickedShelleyLedgerTip      :: !(WithOrigin (ShelleyTip proto era))
       -- | We are counting blocks within an epoch, this means:
       --
@@ -260,12 +261,7 @@ data instance Ticked (LedgerState (ShelleyBlock proto era)) = TickedShelleyLedge
   deriving (Generic)
 
 deriving instance ShelleyBasedEra era
-               => NoThunks (Ticked (LedgerState (ShelleyBlock proto era)))
-
-untickedShelleyLedgerTipPoint ::
-     Ticked (LedgerState (ShelleyBlock proto era))
-  -> Point (ShelleyBlock proto era)
-untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip
+               => NoThunks (Ticked1 (LedgerState (ShelleyBlock proto era)) mk)
 
 instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) where
   type LedgerErr (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerError era
@@ -392,10 +388,10 @@ applyHelper ::
      )
   -> LedgerConfig (ShelleyBlock proto era)
   -> ShelleyBlock proto era
-  -> Ticked (LedgerState (ShelleyBlock proto era))
+  -> Ticked1 (LedgerState (ShelleyBlock proto era)) mk
   -> m (LedgerResult
           (LedgerState (ShelleyBlock proto era))
-          (LedgerState (ShelleyBlock proto era)))
+          (LedgerState (ShelleyBlock proto era) mk))
 applyHelper f cfg blk TickedShelleyLedgerState{
                           tickedShelleyLedgerTransition
                         , tickedShelleyLedgerState
@@ -549,7 +545,7 @@ decodeShelleyTransition = do
 
 encodeShelleyLedgerState ::
      ShelleyCompatible proto era
-  => LedgerState (ShelleyBlock proto era)
+  => LedgerState (ShelleyBlock proto era) mk
   -> Encoding
 encodeShelleyLedgerState
     ShelleyLedgerState { shelleyLedgerTip
@@ -564,13 +560,13 @@ encodeShelleyLedgerState
       ]
 
 decodeShelleyLedgerState ::
-     forall era proto s. ShelleyCompatible proto era
-  => Decoder s (LedgerState (ShelleyBlock proto era))
+     forall era proto s mk. ShelleyCompatible proto era
+  => Decoder s (LedgerState (ShelleyBlock proto era) mk)
 decodeShelleyLedgerState = decodeVersion [
       (serialisationFormatVersion2, Decode decodeShelleyLedgerState2)
     ]
   where
-    decodeShelleyLedgerState2 :: Decoder s' (LedgerState (ShelleyBlock proto era))
+    decodeShelleyLedgerState2 :: Decoder s' (LedgerState (ShelleyBlock proto era) mk)
     decodeShelleyLedgerState2 = do
       enforceSize "LedgerState ShelleyBlock" 3
       shelleyLedgerTip        <- decodeWithOrigin decodeShelleyTip

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs
@@ -73,7 +73,7 @@ import           Ouroboros.Consensus.Shelley.Eras
 import           Ouroboros.Consensus.Shelley.Ledger.Block
 import           Ouroboros.Consensus.Shelley.Ledger.Ledger
                      (ShelleyLedgerConfig (shelleyLedgerGlobals),
-                     Ticked (TickedShelleyLedgerState, tickedShelleyLedgerState),
+                     Ticked1 (TickedShelleyLedgerState, tickedShelleyLedgerState),
                      getPParams)
 
 data instance GenTx (ShelleyBlock proto era) = ShelleyTx !(SL.TxId (EraCrypto era)) !(Tx era)
@@ -224,9 +224,9 @@ applyShelleyTx :: forall era proto.
   -> WhetherToIntervene
   -> SlotNo
   -> GenTx (ShelleyBlock proto era)
-  -> TickedLedgerState (ShelleyBlock proto era)
+  -> TickedLedgerState (ShelleyBlock proto era) Canonical
   -> Except (ApplyTxErr (ShelleyBlock proto era))
-       ( TickedLedgerState (ShelleyBlock proto era)
+       ( TickedLedgerState (ShelleyBlock proto era) Canonical
        , Validated (GenTx (ShelleyBlock proto era))
        )
 applyShelleyTx cfg wti slot (ShelleyTx _ tx) st = do
@@ -249,8 +249,8 @@ reapplyShelleyTx ::
   => LedgerConfig (ShelleyBlock proto era)
   -> SlotNo
   -> Validated (GenTx (ShelleyBlock proto era))
-  -> TickedLedgerState (ShelleyBlock proto era)
-  -> Except (ApplyTxErr (ShelleyBlock proto era)) (TickedLedgerState (ShelleyBlock proto era))
+  -> TickedLedgerState (ShelleyBlock proto era) Canonical
+  -> Except (ApplyTxErr (ShelleyBlock proto era)) (TickedLedgerState (ShelleyBlock proto era) Canonical)
 reapplyShelleyTx cfg slot vgtx st = do
     mempoolState' <-
         SL.reapplyTx
@@ -275,8 +275,8 @@ set lens inner outer =
 theLedgerLens ::
      Functor f
   => (SL.LedgerState era -> f (SL.LedgerState era))
-  -> TickedLedgerState (ShelleyBlock proto era)
-  -> f (TickedLedgerState (ShelleyBlock proto era))
+  -> TickedLedgerState (ShelleyBlock proto era) Canonical
+  -> f (TickedLedgerState (ShelleyBlock proto era) Canonical)
 theLedgerLens f x =
         (\y -> x{tickedShelleyLedgerState = y})
     <$> SL.overNewEpochState f (tickedShelleyLedgerState x)

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs
@@ -113,7 +113,7 @@ instance
     mapForecast (translateTickedLedgerView @(TPraos crypto) @(Praos crypto)) $
       ledgerViewForecastAt @(ShelleyBlock (TPraos crypto) era) cfg st'
     where
-      st' :: LedgerState (ShelleyBlock (TPraos crypto) era)
+      st' :: LedgerState (ShelleyBlock (TPraos crypto) era) Canonical
       st' =
         ShelleyLedgerState
           { shelleyLedgerTip = coerceTip <$> shelleyLedgerTip st,

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs
@@ -17,6 +17,7 @@ import           Ouroboros.Network.Block (Serialised, unwrapCBORinCBOR,
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HeaderValidation
+import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId)
 import           Ouroboros.Consensus.Node.Run
 import           Ouroboros.Consensus.Node.Serialisation
@@ -53,9 +54,9 @@ instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) (Hea
 instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) (Lazy.ByteString -> Header (ShelleyBlock proto era)) where
   decodeDisk _ = decodeShelleyHeader
 
-instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) (LedgerState (ShelleyBlock proto era)) where
+instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) (LedgerState (ShelleyBlock proto era) Canonical) where
   encodeDisk _ = encodeShelleyLedgerState
-instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) (LedgerState (ShelleyBlock proto era)) where
+instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) (LedgerState (ShelleyBlock proto era) Canonical) where
   decodeDisk _ = decodeShelleyLedgerState
 
 -- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/TPraos.hs
@@ -322,7 +322,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
         , shelleyStorageConfigSecurityParam     = tpraosSecurityParam     tpraosParams
         }
 
-    initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era)
+    initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era) Canonical
     initLedgerState = ShelleyLedgerState {
         shelleyLedgerTip        = Origin
       , shelleyLedgerState      =
@@ -335,7 +335,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased {
     initChainDepState = TPraosState Origin $
       SL.initialChainDepState initialNonce (SL.sgGenDelegs genesis)
 
-    initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era)
+    initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era) Canonical
     initExtLedgerState = ExtLedgerState {
         ledgerState = initLedgerState
       , headerState = genesisHeaderState initChainDepState

diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs
@@ -41,6 +41,7 @@ import           Ouroboros.Consensus.Forecast
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
 import           Ouroboros.Consensus.HardFork.Combinator.Util.InPairs
                      (RequiringBoth (..), ignoringBoth)
 import           Ouroboros.Consensus.HardFork.History (Bound (boundSlot))
@@ -134,7 +135,7 @@ shelleyTransition ::
      forall era proto. ShelleyCompatible proto era
   => PartialLedgerConfig (ShelleyBlock proto era)
   -> Word16   -- ^ Next era's major protocol version
-  -> LedgerState (ShelleyBlock proto era)
+  -> LedgerState (ShelleyBlock proto era) Canonical
   -> Maybe EpochNo
 shelleyTransition ShelleyPartialLedgerConfig{..}
                   transitionMajorVersion
@@ -248,7 +249,7 @@ forecastAcrossShelley ::
   -> ShelleyLedgerConfig eraTo
   -> Bound  -- ^ Transition between the two eras
   -> SlotNo -- ^ Forecast for this slot
-  -> LedgerState (ShelleyBlock protoFrom eraFrom)
+  -> LedgerState (ShelleyBlock protoFrom eraFrom) Canonical
   -> Except OutsideForecastRange (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo)))
 forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom
     | forecastFor < maxFor
@@ -327,11 +328,11 @@ instance ( ShelleyBasedEra era
          , SL.TranslateEra era (ShelleyTip proto)
          , SL.TranslateEra era SL.NewEpochState
          , SL.TranslationError era SL.NewEpochState ~ Void
-         ) => SL.TranslateEra era (LedgerState :.: ShelleyBlock proto) where
-  translateEra ctxt (Comp (ShelleyLedgerState tip state _transition)) = do
+         ) => SL.TranslateEra era (Flip LedgerState Canonical :.: ShelleyBlock proto) where
+  translateEra ctxt (Comp (Flip (ShelleyLedgerState tip state _transition))) = do
       tip'   <- mapM (SL.translateEra ctxt) tip
       state' <- SL.translateEra ctxt state
-      return $ Comp $ ShelleyLedgerState {
+      return $ Comp $ Flip $ ShelleyLedgerState {
           shelleyLedgerTip        = tip'
         , shelleyLedgerState      = state'
         , shelleyLedgerTransition = ShelleyTransitionInfo 0