WIP

Author: jasagredo

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/Combinators.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DerivingStrategies #-}
@@ -83,6 +85,8 @@ import Ouroboros.Consensus.Ledger.Tables.Basics
 import Ouroboros.Consensus.Ledger.Tables.MapKind
 import Ouroboros.Consensus.Util ((...:), (..:), (.:))
 import Ouroboros.Consensus.Util.IndexedMemPack
+import Data.Proxy
+import Lens.Micro
 
 {-------------------------------------------------------------------------------
   Common constraints
@@ -112,11 +116,12 @@ type LedgerTableConstraints' l k v =
 
 -- | Like 'bmap', but for ledger tables.
 ltmap ::
-  LedgerTableConstraints l =>
+  forall l (tag :: TAG) mk1 mk2. LedgerTableConstraints l =>
+  Proxy tag ->
   (forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v) ->
   LedgerTables l mk1 ->
   LedgerTables l mk2
-ltmap f (LedgerTables x) = LedgerTables $ f x
+ltmap p f tbs = tbs & onTable (Proxy @l) p %~ Table . f . getTable
 
 {-------------------------------------------------------------------------------
   Traversable

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/MapKind.hs

@@ -18,7 +18,7 @@ module Ouroboros.Consensus.Ledger.Tables.MapKind
   , NoThunksMK
   , ShowMK
   , ZeroableMK (..)
-  , bimapLedgerTables
+--   , bimapLedgerTables
 
     -- * Concrete MapKinds
   , CodecMK (..)
@@ -35,6 +35,8 @@ import qualified Codec.CBOR.Encoding as CBOR
 import Data.Kind (Constraint)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import Data.Proxy
+import Data.SOP.Strict
 import Data.Set (Set)
 import qualified Data.Set as Set
 import GHC.Generics (Generic)
@@ -78,26 +80,35 @@ class
   (forall k v. (NoThunks k, NoThunks v) => NoThunks (mk k v)) =>
   NoThunksMK mk
 
--- | Map both keys and values in ledger tables.
---
--- For keys, it has the same caveats as 'Data.Map.Strict.mapKeys' or
--- `Data.Set.map', namely that only injective functions are suitable to be used
--- here.
-bimapLedgerTables ::
-  forall x y mk.
-  ( CanMapKeysMK mk
-  , CanMapMK mk
-  , Ord (TxIn y)
-  ) =>
-  (TxIn x -> TxIn y) ->
-  (TxOut x -> TxOut y) ->
-  LedgerTables x mk ->
-  LedgerTables y mk
-bimapLedgerTables f g =
-  LedgerTables
-    . mapKeysMK f
-    . mapMK g
-    . getLedgerTables
+-- -- | Map both keys and values in ledger tables.
+-- --
+-- -- For keys, it has the same caveats as 'Data.Map.Strict.mapKeys' or
+-- -- `Data.Set.map', namely that only injective functions are suitable to be used
+-- -- here.
+-- bimapLedgerTables ::
+--   forall tag x y mk.
+--   ( CanMapKeysMK mk
+--   , CanMapMK mk
+--   , Ord (TxIn y)
+--   ) =>
+--   (TxIn x -> TxIn y) ->
+--   (TxOut x -> TxOut y) ->
+--   (Credential x -> Credential y) ->
+--   (AccountState x -> AccountState y) ->
+--   LedgerTables x mk ->
+--   LedgerTables y mk
+-- bimapLedgerTables f g h i t =
+
+--     `onUTxOTable` ( Table
+--                       . mapKeysMK f
+--                       . mapMK g
+--                       . getTable
+--                   )
+--     `onAccountsTable` ( Table
+--                           . mapKeysMK f
+--                           . mapMK g
+--                           . getTable
+--                       )
 
 {-------------------------------------------------------------------------------
   EmptyMK