Merge pull request #296 from input-output-hk/newhoggy/simplify-DebugL…

…edgerState-with-eons Simplify `DebugLedgerState` with eons
IntersectMBO · Oct 5, 2023 · 4a8a343 · 4a8a343
2 parents dd8e898 + c3321be
commit 4a8a343
Show file tree

Hide file tree

Showing 2 changed files with 28 additions and 46 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Eras/Constraints.hs b/cardano-api/internal/Cardano/Api/Eras/Constraints.hs
@@ -21,7 +21,6 @@ import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eras.Core
 import           Cardano.Api.Modes
 import           Cardano.Api.Orphans ()
-import           Cardano.Api.Query.Types
 
 import qualified Cardano.Crypto.Hash.Blake2b as Blake2b
 import qualified Cardano.Crypto.Hash.Class as C
@@ -72,11 +71,9 @@ type ShelleyBasedEraConstraints era =
   , L.ShelleyEraTxBody (ShelleyLedgerEra era)
   , L.ShelleyEraTxCert (ShelleyLedgerEra era)
   , FromCBOR (Consensus.ChainDepState (ConsensusProtocol era))
-  , FromCBOR (DebugLedgerState era)
   , IsCardanoEra era
   , IsShelleyBasedEra era
   , ToJSON (Consensus.ChainDepState (ConsensusProtocol era))
-  , ToJSON (DebugLedgerState era)
   , Typeable era
   )
 

diff --git a/cardano-api/internal/Cardano/Api/Query/Types.hs b/cardano-api/internal/Cardano/Api/Query/Types.hs
@@ -1,63 +1,48 @@
 {-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Cardano.Api.Query.Types
   ( DebugLedgerState(..)
   , toDebugLedgerStatePair
   ) where
 
 import           Cardano.Api.Eon.ShelleyBasedEra
+import           Cardano.Api.Eras.Constraints
+import           Cardano.Api.Orphans ()
 
 import           Cardano.Binary
-import           Cardano.Ledger.Binary
 import qualified Cardano.Ledger.Binary.Plain as Plain
 import qualified Cardano.Ledger.Shelley.API as Shelley
-import qualified Cardano.Ledger.Shelley.Core as Core
-import qualified Cardano.Ledger.Shelley.LedgerState as Shelley
-import qualified Ouroboros.Consensus.Cardano.Block as Consensus
 
 import           Data.Aeson (ToJSON (..), object, (.=))
 import qualified Data.Aeson as Aeson
-import           Data.Typeable
 
-data DebugLedgerState era where
-  DebugLedgerState ::
-    ( ShelleyLedgerEra era ~ ledgerera
-    )
-    => Shelley.NewEpochState ledgerera
-    -> DebugLedgerState era
-
-instance
-    ( Typeable era
-    , Core.EraTxOut (ShelleyLedgerEra era)
-    , Core.EraGov (ShelleyLedgerEra era)
-    , DecCBOR (Shelley.StashedAVVMAddresses (ShelleyLedgerEra era))
-    ) => FromCBOR (DebugLedgerState era) where
-  fromCBOR = DebugLedgerState <$>
-    (fromCBOR :: Plain.Decoder s (Shelley.NewEpochState (ShelleyLedgerEra era)))
-
--- TODO: Shelley based era class!
-instance ( IsShelleyBasedEra era
-         , ShelleyLedgerEra era ~ ledgerera
-         , Consensus.ShelleyBasedEra ledgerera
-         ) => ToJSON (DebugLedgerState era) where
-  toJSON = object . toDebugLedgerStatePair
-  toEncoding = Aeson.pairs . mconcat . toDebugLedgerStatePair
-
-toDebugLedgerStatePair ::
-  ( ShelleyLedgerEra era ~ ledgerera
-  , Consensus.ShelleyBasedEra ledgerera
-  , Aeson.KeyValue a
-  ) => DebugLedgerState era -> [a]
-toDebugLedgerStatePair (DebugLedgerState newEpochS) =
+newtype DebugLedgerState era = DebugLedgerState
+  { unDebugLedgerState :: Shelley.NewEpochState (ShelleyLedgerEra era)
+  }
+
+instance IsShelleyBasedEra era => FromCBOR (DebugLedgerState era) where
+  fromCBOR =
+    shelleyBasedEraConstraints (shelleyBasedEra @era) $
+      DebugLedgerState <$>
+        (fromCBOR :: Plain.Decoder s (Shelley.NewEpochState (ShelleyLedgerEra era)))
+
+instance IsShelleyBasedEra era => ToJSON (DebugLedgerState era) where
+  toJSON =
+    let sbe = shelleyBasedEra @era in
+    shelleyBasedEraConstraints sbe $ object . toDebugLedgerStatePair sbe
+  toEncoding =
+    let sbe = shelleyBasedEra @era in
+    shelleyBasedEraConstraints sbe $ Aeson.pairs . mconcat . toDebugLedgerStatePair sbe
+
+toDebugLedgerStatePair :: ()
+  => Aeson.KeyValue a
+  => ShelleyBasedEra era
+  -> DebugLedgerState era
+  -> [a]
+toDebugLedgerStatePair sbe (DebugLedgerState newEpochS) =
+  shelleyBasedEraConstraints sbe $
     let !nesEL = Shelley.nesEL newEpochS
         !nesBprev = Shelley.nesBprev newEpochS
         !nesBcur = Shelley.nesBcur newEpochS