Introduce Canonical map kind to ouroboros-consensus

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>

ouroboros-consensus/src/Ouroboros/Consensus/Block/Forging.hs

@@ -144,11 +144,11 @@ data BlockForging m blk = BlockForging {
       -- PRECONDITION: 'checkCanForge' returned @Right ()@.
     , forgeBlock ::
            TopLevelConfig blk
-        -> BlockNo                      -- Current block number
-        -> SlotNo                       -- Current slot number
-        -> TickedLedgerState blk        -- Current ledger state
-        -> [Validated (GenTx blk)]      -- Contents of the mempool
-        -> IsLeader (BlockProtocol blk) -- Proof we are leader
+        -> BlockNo                         -- Current block number
+        -> SlotNo                          -- Current slot number
+        -> TickedLedgerState blk Canonical -- Current ledger state
+        -> [Validated (GenTx blk)]         -- Contents of the mempool
+        -> IsLeader (BlockProtocol blk)    -- Proof we are leader
         -> m blk
     }
 
@@ -163,7 +163,7 @@ data BlockForging m blk = BlockForging {
 takeLargestPrefixThatFits ::
      TxLimits blk
   => TxLimits.Overrides blk
-  -> TickedLedgerState blk
+  -> TickedLedgerState blk Canonical
   -> [Validated (GenTx blk)]
   -> [Validated (GenTx blk)]
 takeLargestPrefixThatFits overrides ledger txs =

ouroboros-consensus/src/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs

@@ -49,7 +49,7 @@ newtype BackoffDelay = BackoffDelay NominalDiffTime
 data HardForkBlockchainTimeArgs m blk = HardForkBlockchainTimeArgs
   { hfbtBackoffDelay   :: m BackoffDelay
     -- ^ See 'BackoffDelay'
-  , hfbtGetLedgerState :: STM m (LedgerState blk)
+  , hfbtGetLedgerState :: STM m (LedgerState blk Canonical)
   , hfbtLedgerConfig   :: LedgerConfig blk
   , hfbtRegistry       :: ResourceRegistry m
   , hfbtSystemTime     :: SystemTime m
@@ -98,7 +98,7 @@ hardForkBlockchainTime args = do
       , hfbtMaxClockRewind = maxClockRewind
       } = args
 
-    summarize :: LedgerState blk -> HF.Summary (HardForkIndices blk)
+    summarize :: LedgerState blk Canonical -> HF.Summary (HardForkIndices blk)
     summarize st = hardForkSummary cfg st
 
     loop :: HF.RunWithCachedSummary xs m

ouroboros-consensus/src/Ouroboros/Consensus/Fragment/InFuture.hs

@@ -50,7 +50,7 @@ data CheckInFuture m blk = CheckInFuture {
        --
        -- > checkInFuture vf >>= \(af, fut) ->
        -- >   validatedFragment vf == af <=> null fut
-       checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk)
+       checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk Canonical)
                      -> m (AnchoredFragment (Header blk), [InFuture m blk])
     }
   deriving NoThunks

ouroboros-consensus/src/Ouroboros/Consensus/Fragment/Validated.hs

@@ -43,7 +43,7 @@ data ValidatedFragment b l = UnsafeValidatedFragment {
 {-# COMPLETE ValidatedFragment #-}
 
 pattern ValidatedFragment ::
-     (IsLedger l, HasHeader b, HeaderHash b ~ HeaderHash l, HasCallStack)
+     (GetTip l, HasHeader b, HeaderHash b ~ HeaderHash l, HasCallStack)
   => AnchoredFragment b -> l -> ValidatedFragment b l
 pattern ValidatedFragment f l <- UnsafeValidatedFragment f l
   where
@@ -54,7 +54,7 @@ validatedTip = AF.headPoint . validatedFragment
 
 invariant ::
      forall l b.
-     (IsLedger l, HasHeader b, HeaderHash b ~ HeaderHash l)
+     (GetTip l, HasHeader b, HeaderHash b ~ HeaderHash l)
   => ValidatedFragment b l
   -> Either String ()
 invariant (ValidatedFragment fragment ledger)
@@ -75,7 +75,7 @@ invariant (ValidatedFragment fragment ledger)
 -- | Constructor for 'ValidatedFragment' that checks the invariant
 new ::
      forall l b.
-     (IsLedger l, HasHeader b, HeaderHash b ~ HeaderHash l, HasCallStack)
+     (GetTip l, HasHeader b, HeaderHash b ~ HeaderHash l, HasCallStack)
   => AnchoredFragment b
   -> l
   -> ValidatedFragment b l

ouroboros-consensus/src/Ouroboros/Consensus/Fragment/ValidatedDiff.hs

@@ -49,7 +49,7 @@ pattern ValidatedChainDiff d l <- UnsafeValidatedChainDiff d l
 -- > getTip chainDiff == ledgerTipPoint ledger
 new ::
      forall b l.
-     (IsLedger l, HasHeader b, HeaderHash l ~ HeaderHash b, HasCallStack)
+     (GetTip l, HasHeader b, HeaderHash l ~ HeaderHash b, HasCallStack)
   => ChainDiff b
   -> l
   -> ValidatedChainDiff b l
@@ -69,7 +69,7 @@ new chainDiff ledger =
           show chainDiffTip <> " /= " <> show ledgerTip
 
 toValidatedFragment
-  :: (IsLedger l, HasHeader b, HeaderHash l ~ HeaderHash b, HasCallStack)
+  :: (GetTip l, HasHeader b, HeaderHash l ~ HeaderHash b, HasCallStack)
   => ValidatedChainDiff b l
   -> ValidatedFragment b l
 toValidatedFragment (UnsafeValidatedChainDiff cs l) =

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Abstract.hs

@@ -50,7 +50,7 @@ class HasHardForkHistory blk where
   -- information, and so this function becomes little more than a projection
   -- (indeed, in this case the 'LedgerState' should be irrelevant).
   hardForkSummary :: LedgerConfig blk
-                  -> LedgerState blk
+                  -> LedgerState blk Canonical
                   -> HardFork.Summary (HardForkIndices blk)
 
 -- | Helper function that can be used to define 'hardForkSummary'
@@ -63,7 +63,7 @@ class HasHardForkHistory blk where
 -- hard fork combinator).
 neverForksHardForkSummary :: (LedgerConfig blk -> HardFork.EraParams)
                           -> LedgerConfig blk
-                          -> LedgerState blk
+                          -> LedgerState blk Canonical
                           -> HardFork.Summary '[blk]
 neverForksHardForkSummary getParams cfg _st =
     HardFork.neverForksSummary eraEpochSize eraSlotLength

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs

@@ -88,7 +88,7 @@ class ( LedgerSupportsProtocol blk
   singleEraTransition :: PartialLedgerConfig blk
                       -> EraParams -- ^ Current era parameters
                       -> Bound     -- ^ Start of this era
-                      -> LedgerState blk
+                      -> LedgerState blk Canonical
                       -> Maybe EpochNo
 
   -- | Era information (for use in error messages)
@@ -101,7 +101,7 @@ singleEraTransition' :: SingleEraBlock blk
                      => WrapPartialLedgerConfig blk
                      -> EraParams
                      -> Bound
-                     -> LedgerState blk -> Maybe EpochNo
+                     -> LedgerState blk Canonical -> Maybe EpochNo
 singleEraTransition' = singleEraTransition . unwrapPartialLedgerConfig
 
 {-------------------------------------------------------------------------------

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs

@@ -59,6 +59,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
 import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import           Ouroboros.Consensus.HardFork.Combinator.State.Instances ()
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors (Flip)
 
 {-------------------------------------------------------------------------------
   Hard fork protocol, block, and ledger state
@@ -76,13 +77,13 @@ instance Typeable xs => ShowProxy (HardForkBlock xs) where
 type instance BlockProtocol (HardForkBlock xs) = HardForkProtocol xs
 type instance HeaderHash    (HardForkBlock xs) = OneEraHash       xs
 
-newtype instance LedgerState (HardForkBlock xs) = HardForkLedgerState {
-      hardForkLedgerStatePerEra :: HardForkState LedgerState xs
+newtype instance LedgerState (HardForkBlock xs) mk = HardForkLedgerState {
+      hardForkLedgerStatePerEra :: HardForkState (Flip LedgerState mk) xs
     }
 
-deriving stock   instance CanHardFork xs => Show (LedgerState (HardForkBlock xs))
-deriving stock   instance CanHardFork xs => Eq   (LedgerState (HardForkBlock xs))
-deriving newtype instance CanHardFork xs => NoThunks (LedgerState (HardForkBlock xs))
+deriving stock   instance CanHardFork xs => Show (LedgerState (HardForkBlock xs) Canonical)
+deriving stock   instance CanHardFork xs => Eq   (LedgerState (HardForkBlock xs) Canonical)
+deriving newtype instance CanHardFork xs => NoThunks (LedgerState (HardForkBlock xs) Canonical)
 
 {-------------------------------------------------------------------------------
   Protocol config

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs

@@ -52,6 +52,8 @@ import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseDisk ()
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseNodeToClient ()
 import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.SerialiseNodeToNode ()
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
+                     (Flip (..))
 
 {-------------------------------------------------------------------------------
   Simple patterns
@@ -169,11 +171,11 @@ pattern DegenBlockConfig x <- (project -> x)
 
 pattern DegenLedgerState ::
      NoHardForks b
-  => LedgerState b
-  -> LedgerState (HardForkBlock '[b])
-pattern DegenLedgerState x <- (project -> x)
+  => LedgerState b Canonical
+  -> LedgerState (HardForkBlock '[b]) Canonical
+pattern DegenLedgerState x <- (unFlip . project . Flip -> x)
   where
-    DegenLedgerState x = inject x
+    DegenLedgerState x = unFlip $ inject $ Flip x
 
 {-------------------------------------------------------------------------------
   Dealing with the config

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs

@@ -22,6 +22,8 @@ import           Ouroboros.Consensus.Util.Counting (exactlyTwo)
 import           Ouroboros.Consensus.Util.OptNP (OptNP (..))
 
 import           Ouroboros.Consensus.HardFork.Combinator
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
+                     (Flip (..))
 import qualified Ouroboros.Consensus.HardFork.History as History
 
 {-------------------------------------------------------------------------------
@@ -79,7 +81,7 @@ protocolInfoBinary protocolInfo1 eraParams1 toPartialConsensusConfig1 toPartialL
       , pInfoInitLedger = ExtLedgerState {
             ledgerState =
               HardForkLedgerState $
-                initHardForkState initLedgerState1
+                initHardForkState $ Flip initLedgerState1
           , headerState =
               genesisHeaderState $
                 initHardForkState $

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs

@@ -29,6 +29,7 @@ import           Ouroboros.Consensus.Config
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation (AnnTip, HeaderState (..),
                      genesisHeaderState)
+import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
@@ -38,6 +39,8 @@ import           Ouroboros.Consensus.Util.SOP
 
 import           Ouroboros.Consensus.HardFork.Combinator
 import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
+                     (Flip (..))
 import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs
 
 {-------------------------------------------------------------------------------
@@ -149,9 +152,9 @@ instance Inject (SomeSecond BlockQuery) where
 instance Inject AnnTip where
   inject _ = undistribAnnTip .: injectNS' (Proxy @AnnTip)
 
-instance Inject LedgerState where
+instance Inject (Flip LedgerState Canonical) where
   inject startBounds idx =
-      HardForkLedgerState . injectHardForkState startBounds idx
+      Flip . HardForkLedgerState . injectHardForkState startBounds idx
 
 instance Inject WrapChainDepState where
   inject startBounds idx =
@@ -165,9 +168,9 @@ instance Inject HeaderState where
                             $ WrapChainDepState headerStateChainDep
       }
 
-instance Inject ExtLedgerState where
-  inject startBounds idx ExtLedgerState {..} = ExtLedgerState {
-        ledgerState = inject startBounds idx ledgerState
+instance Inject (Flip ExtLedgerState Canonical) where
+  inject startBounds idx (Flip ExtLedgerState {..}) = Flip $ ExtLedgerState {
+        ledgerState = unFlip $ inject startBounds idx (Flip ledgerState)
       , headerState = inject startBounds idx headerState
       }
 
@@ -188,8 +191,8 @@ instance Inject ExtLedgerState where
 injectInitialExtLedgerState ::
      forall x xs. CanHardFork (x ': xs)
   => TopLevelConfig (HardForkBlock (x ': xs))
-  -> ExtLedgerState x
-  -> ExtLedgerState (HardForkBlock (x ': xs))
+  -> ExtLedgerState x Canonical
+  -> ExtLedgerState (HardForkBlock (x ': xs)) Canonical
 injectInitialExtLedgerState cfg extLedgerState0 =
     ExtLedgerState {
         ledgerState = targetEraLedgerState
@@ -204,15 +207,15 @@ injectInitialExtLedgerState cfg extLedgerState0 =
              (hardForkLedgerStatePerEra targetEraLedgerState))
           cfg
 
-    targetEraLedgerState :: LedgerState (HardForkBlock (x ': xs))
+    targetEraLedgerState :: LedgerState (HardForkBlock (x ': xs)) Canonical
     targetEraLedgerState =
         HardForkLedgerState $
           -- We can immediately extend it to the right slot, executing any
           -- scheduled hard forks in the first slot
           State.extendToSlot
             (configLedger cfg)
             (SlotNo 0)
-            (initHardForkState (ledgerState extLedgerState0))
+            (initHardForkState (Flip $ ledgerState extLedgerState0))
 
     firstEraChainDepState :: HardForkChainDepState (x ': xs)
     firstEraChainDepState =

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs

@@ -70,6 +70,8 @@ import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
 import           Ouroboros.Consensus.HardFork.Combinator.Protocol
 import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Functors
+                     (Flip (..))
 import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Telescope as Telescope
 
 {-------------------------------------------------------------------------------
@@ -198,7 +200,7 @@ instance Isomorphic StorageConfig where
   project = defaultProjectNP
   inject  = defaultInjectNP
 
-instance Isomorphic LedgerState where
+instance Isomorphic (Flip LedgerState Canonical) where
   project = defaultProjectSt
   inject  = defaultInjectSt
 
@@ -337,29 +339,29 @@ instance Isomorphic HeaderState where
       , headerStateChainDep = inject' (Proxy @(WrapChainDepState blk)) headerStateChainDep
       }
 
-instance Isomorphic (Ticked :.: LedgerState) where
+instance Isomorphic (FlipTickedLedgerState Canonical) where
   project =
         State.currentState
       . Telescope.fromTZ
       . getHardForkState
       . tickedHardForkLedgerStatePerEra
-      . unComp
+      . getFlipTickedLedgerState
 
   inject =
-        Comp
+        FlipTickedLedgerState
       . TickedHardForkLedgerState TransitionImpossible
       . HardForkState
       . Telescope.TZ
       . State.Current History.initBound
 
-instance Isomorphic ExtLedgerState where
-  project ExtLedgerState{..} = ExtLedgerState {
-        ledgerState = project ledgerState
+instance Isomorphic (Flip ExtLedgerState Canonical) where
+  project (Flip ExtLedgerState{..}) = Flip $ ExtLedgerState {
+        ledgerState = unFlip $ project $ Flip ledgerState
       , headerState = project headerState
       }
 
-  inject ExtLedgerState{..} = ExtLedgerState {
-        ledgerState = inject ledgerState
+  inject (Flip ExtLedgerState{..}) = Flip $ ExtLedgerState {
+        ledgerState = unFlip $ inject $ Flip ledgerState
       , headerState = inject headerState
       }
 
@@ -372,11 +374,11 @@ instance Isomorphic AnnTip where
 instance Functor m => Isomorphic (InitChainDB m) where
   project :: forall blk. NoHardForks blk
           => InitChainDB m (HardForkBlock '[blk]) -> InitChainDB m blk
-  project = InitChainDB.map (inject' (Proxy @(I blk))) project
+  project = InitChainDB.map (inject' (Proxy @(I blk))) (unFlip . project . Flip)
 
   inject :: forall blk. NoHardForks blk
          => InitChainDB m blk -> InitChainDB m (HardForkBlock '[blk])
-  inject = InitChainDB.map (project' (Proxy @(I blk))) inject
+  inject = InitChainDB.map (project' (Proxy @(I blk))) (unFlip . inject . Flip)
 
 instance Isomorphic ProtocolClientInfo where
   project ProtocolClientInfo{..} = ProtocolClientInfo {
@@ -443,7 +445,7 @@ instance Functor m => Isomorphic (BlockForging m) where
                                    (inject cfg)
                                    bno
                                    sno
-                                   (unComp (inject (Comp tickedLgrSt)))
+                                   (getFlipTickedLedgerState (inject (FlipTickedLedgerState tickedLgrSt)))
                                    (inject' (Proxy @(WrapValidatedGenTx blk)) <$> txs)
                                    (inject' (Proxy @(WrapIsLeader blk)) isLeader)
       }
@@ -486,7 +488,7 @@ instance Functor m => Isomorphic (BlockForging m) where
                                    (project cfg)
                                    bno
                                    sno
-                                   (unComp (project (Comp tickedLgrSt)))
+                                   (getFlipTickedLedgerState (project (FlipTickedLedgerState tickedLgrSt)))
                                    (project' (Proxy @(WrapValidatedGenTx blk)) <$> txs)
                                    (project' (Proxy @(WrapIsLeader blk)) isLeader)
       }
@@ -505,15 +507,15 @@ instance Functor m => Isomorphic (ProtocolInfo m) where
           => ProtocolInfo m (HardForkBlock '[blk]) -> ProtocolInfo m blk
   project ProtocolInfo {..} = ProtocolInfo {
         pInfoConfig       = project pInfoConfig
-      , pInfoInitLedger   = project pInfoInitLedger
+      , pInfoInitLedger   = unFlip $ project $ Flip pInfoInitLedger
       , pInfoBlockForging = fmap project <$> pInfoBlockForging
       }
 
   inject :: forall blk. NoHardForks blk
          => ProtocolInfo m blk -> ProtocolInfo m (HardForkBlock '[blk])
   inject ProtocolInfo {..} = ProtocolInfo {
         pInfoConfig       = inject pInfoConfig
-      , pInfoInitLedger   = inject pInfoInitLedger
+      , pInfoInitLedger   = unFlip $ inject $ Flip pInfoInitLedger
       , pInfoBlockForging = fmap inject <$> pInfoBlockForging
       }