From fd83458e4c43cc92711554ac6fbc80bdf3607beb Mon Sep 17 00:00:00 2001
From: Nicholas Clarke <nicholas.clarke@iohk.io>
Date: Wed, 30 Mar 2022 11:31:16 +0200
Subject: [PATCH] Define 'GetLedgerView' for Babbage.

This instance is a little (well, a lot) suspicious, since we don't
actually have extra entropy in Babbage. We rely on the fact that this
type is only used to construct the `Praos` ledger view, which is much
simler (it looks like this:

```
data LedgerView crypto = LedgerView
  { -- | Stake distribution
    lvPoolDistr     :: SL.PoolDistr crypto,
    -- | Maximum header size
    lvMaxHeaderSize :: !Natural,
    -- | Maximum block body size
    lvMaxBodySize   :: !Natural
  }
  deriving (Show)
```
). So the `error` field will be thrown away without being evaluated.

At some point we should make this situation better, but not before the
Vasil HF.
---
 hie.yaml                                      |  3 ++
 .../cardano-protocol-tpraos.cabal             |  1 +
 .../src/Cardano/Protocol/TPraos/API.hs        | 42 +++++++++++++++++--
 3 files changed, 43 insertions(+), 3 deletions(-)

diff --git a/hie.yaml b/hie.yaml
index fcdd75b9878..ea5539c938b 100644
--- a/hie.yaml
+++ b/hie.yaml
@@ -107,3 +107,6 @@ cradle:
 
     - path: "libs/cardano-ledger-pretty/src"
       component: "lib:cardano-ledger-pretty"
+
+    - path: "libs/cardano-protocol-tpraos"
+      component: "lib:cardano-protocol-tpraos"
diff --git a/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal b/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal
index 2fcd711772d..5285416e7e3 100644
--- a/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal
+++ b/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal
@@ -51,6 +51,7 @@ library
     cardano-binary,
     cardano-crypto-class,
     cardano-ledger-alonzo,
+    cardano-ledger-babbage,
     cardano-ledger-core,
     cardano-ledger-shelley,
     cardano-ledger-shelley-ma,
diff --git a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs
index a4239697bcb..7a1b22bd068 100644
--- a/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs
+++ b/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs
@@ -12,7 +12,6 @@
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 
@@ -46,6 +45,8 @@ import Cardano.Ledger.Allegra (AllegraEra)
 import Cardano.Ledger.Alonzo (AlonzoEra)
 import qualified Cardano.Ledger.Alonzo.PParams as Alonzo (PParams' (..))
 import Cardano.Ledger.BHeaderView (isOverlaySlot)
+import Cardano.Ledger.Babbage (BabbageEra)
+import qualified Cardano.Ledger.Babbage.PParams as Babbage (PParams' (..))
 import Cardano.Ledger.BaseTypes
   ( Globals (..),
     Nonce (NeutralNonce),
@@ -151,7 +152,6 @@ class
     Signal (Core.EraRule "TICKF" era) ~ SlotNo,
     PredicateFailure (Core.EraRule "TICKF" era) ~ TickfPredicateFailure era,
     HasField "_d" (Core.PParams era) UnitInterval,
-    HasField "_extraEntropy" (Core.PParams era) Nonce,
     HasField "_maxBBSize" (Core.PParams era) Natural,
     HasField "_maxBHSize" (Core.PParams era) Natural,
     HasField "_protocolVersion" (Core.PParams era) ProtVer
@@ -161,6 +161,10 @@ class
   currentLedgerView ::
     NewEpochState era ->
     LedgerView (Crypto era)
+  default currentLedgerView ::
+    HasField "_extraEntropy" (Core.PParams era) Nonce =>
+    NewEpochState era ->
+    LedgerView (Crypto era)
   currentLedgerView = view
 
   -- $timetravel
@@ -171,7 +175,9 @@ class
     SlotNo ->
     m (LedgerView (Crypto era))
   default futureLedgerView ::
-    (MonadError (FutureLedgerViewError era) m) =>
+    ( MonadError (FutureLedgerViewError era) m,
+      HasField "_extraEntropy" (Core.PParams era) Nonce
+    ) =>
     Globals ->
     NewEpochState era ->
     SlotNo ->
@@ -186,6 +192,36 @@ instance CC.Crypto c => GetLedgerView (MaryEra c)
 
 instance CC.Crypto c => GetLedgerView (AlonzoEra c)
 
+-- Note that although we do not use TPraos in the Babbage era, we include this
+-- because it makes it simpler to get the ledger view for Praos.
+instance CC.Crypto c => GetLedgerView (BabbageEra c) where
+  currentLedgerView
+    NewEpochState
+      { nesPd,
+        nesEs
+      } =
+      LedgerView
+        { lvD = getField @"_d" . esPp $ nesEs,
+          lvExtraEntropy = error "Extra entropy is not set in the Babbage era",
+          lvPoolDistr = nesPd,
+          lvGenDelegs =
+            _genDelegs . _dstate
+              . _delegationState
+              $ esLState nesEs,
+          lvChainChecks = pparamsToChainChecksPParams . esPp $ nesEs
+        }
+
+  futureLedgerView globals ss slot =
+    liftEither
+      . right currentLedgerView
+      . left FutureLedgerViewError
+      $ res
+    where
+      res =
+        flip runReader globals
+          . applySTS @(Core.EraRule "TICKF" (BabbageEra c))
+          $ TRC ((), ss, slot)
+
 -- | Data required by the Transitional Praos protocol from the Shelley ledger.
 data LedgerView crypto = LedgerView
   { lvD :: UnitInterval,