Use MKs in ouroboros-consensus-cardano-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>

skip-checks: true

ouroboros-consensus-cardano-test/ouroboros-consensus-cardano-test.cabal

@@ -39,6 +39,7 @@ library
 
   build-depends:
     , base                                                                                            >=4.14    && <4.17
+    , cardano-binary
     , cardano-crypto-class
     , cardano-crypto-wrapper
     , cardano-ledger-alonzo-test
@@ -52,6 +53,7 @@ library
     , containers
     , microlens
     , mtl
+    , nothunks
     , ouroboros-consensus                                                                             ^>=0.3
     , ouroboros-consensus-byron                                                                       ^>=0.4.0
     , ouroboros-consensus-byron-test                                                                  ==0.4.0.0
@@ -69,7 +71,7 @@ library
     -Wall -Wcompat -Wincomplete-uni-patterns
     -Wincomplete-record-updates -Wpartial-fields -Widentities
     -Wredundant-constraints -Wmissing-export-lists -Wunused-packages
-    -fno-ignore-asserts
+    -Wno-unticked-promoted-constructors -fno-ignore-asserts
 
 test-suite test
   type:             exitcode-stdio-1.0
@@ -79,6 +81,7 @@ test-suite test
     Test.Consensus.Cardano.ByronCompatibility
     Test.Consensus.Cardano.Golden
     Test.Consensus.Cardano.Serialisation
+    Test.Consensus.Cardano.Translation
     Test.ThreadNet.AllegraMary
     Test.ThreadNet.Cardano
     Test.ThreadNet.MaryAlonzo
@@ -88,14 +91,21 @@ test-suite test
     , base                              >=4.14    && <4.17
     , bytestring
     , cardano-crypto-class
+    , cardano-data
     , cardano-ledger-alonzo
+    , cardano-ledger-alonzo-test
+    , cardano-ledger-babbage-test
+    , cardano-ledger-binary
     , cardano-ledger-byron
+    , cardano-ledger-conway-test
     , cardano-ledger-core
     , cardano-ledger-shelley
+    , cardano-ledger-shelley-test
     , cardano-protocol-tpraos
     , cardano-slotting
     , cborg
     , containers
+    , diff-containers
     , filepath
     , microlens
     , ouroboros-consensus               ^>=0.3
@@ -118,4 +128,5 @@ test-suite test
     -Wall -Wcompat -Wincomplete-uni-patterns
     -Wincomplete-record-updates -Wpartial-fields -Widentities
     -Wredundant-constraints -Wmissing-export-lists -Wunused-packages
-    -fno-ignore-asserts -threaded -rtsopts
+    -Wno-unticked-promoted-constructors -fno-ignore-asserts -threaded
+    -rtsopts

ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Examples.hs

@@ -1,4 +1,8 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE GADTs               #-}
 {-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
@@ -24,20 +28,24 @@ module Test.Consensus.Cardano.Examples (
 
 import           Data.Coerce (Coercible)
 import           Data.SOP.Counting (Exactly (..))
-import           Data.SOP.Index (Index (..))
+import           Data.SOP.Functors (Flip (..))
+import           Data.SOP.Index (Index (..), projectNP)
 import           Data.SOP.Strict
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
 import qualified Ouroboros.Consensus.Byron.Ledger as Byron
 import           Ouroboros.Consensus.Cardano.Block
 import           Ouroboros.Consensus.Cardano.CanHardFork ()
+import           Ouroboros.Consensus.Cardano.Tables ()
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.HardFork.Combinator.Embed.Nary
 import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation (AnnTip)
-import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
+import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr)
+import           Ouroboros.Consensus.Ledger.Tables (EmptyMK, IsMapKind,
+                     ValuesMK)
 import           Ouroboros.Consensus.Protocol.Praos.Translate ()
 import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
 import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
@@ -108,21 +116,22 @@ instance Inject SomeResult where
 
 instance Inject Examples where
   inject startBounds (idx :: Index xs x) Golden.Examples {..} = Golden.Examples {
-        exampleBlock            = inj (Proxy @I)                       exampleBlock
-      , exampleSerialisedBlock  = inj (Proxy @Serialised)              exampleSerialisedBlock
-      , exampleHeader           = inj (Proxy @Header)                  exampleHeader
-      , exampleSerialisedHeader = inj (Proxy @SerialisedHeader)        exampleSerialisedHeader
-      , exampleHeaderHash       = inj (Proxy @WrapHeaderHash)          exampleHeaderHash
-      , exampleGenTx            = inj (Proxy @GenTx)                   exampleGenTx
-      , exampleGenTxId          = inj (Proxy @WrapGenTxId)             exampleGenTxId
-      , exampleApplyTxErr       = inj (Proxy @WrapApplyTxErr)          exampleApplyTxErr
-      , exampleQuery            = inj (Proxy @(SomeSecond BlockQuery)) exampleQuery
-      , exampleResult           = inj (Proxy @SomeResult)              exampleResult
-      , exampleAnnTip           = inj (Proxy @AnnTip)                  exampleAnnTip
-      , exampleLedgerState      = inj (Proxy @LedgerState)             exampleLedgerState
-      , exampleChainDepState    = inj (Proxy @WrapChainDepState)       exampleChainDepState
-      , exampleExtLedgerState   = inj (Proxy @ExtLedgerState)          exampleExtLedgerState
-      , exampleSlotNo           =                                      exampleSlotNo
+        exampleBlock            = inj (Proxy @I)                             exampleBlock
+      , exampleSerialisedBlock  = inj (Proxy @Serialised)                    exampleSerialisedBlock
+      , exampleHeader           = inj (Proxy @Header)                        exampleHeader
+      , exampleSerialisedHeader = inj (Proxy @SerialisedHeader)              exampleSerialisedHeader
+      , exampleHeaderHash       = inj (Proxy @WrapHeaderHash)                exampleHeaderHash
+      , exampleGenTx            = inj (Proxy @GenTx)                         exampleGenTx
+      , exampleGenTxId          = inj (Proxy @WrapGenTxId)                   exampleGenTxId
+      , exampleApplyTxErr       = inj (Proxy @WrapApplyTxErr)                exampleApplyTxErr
+      , exampleQuery            = inj (Proxy @(SomeSecond BlockQuery))       exampleQuery
+      , exampleResult           = inj (Proxy @SomeResult)                    exampleResult
+      , exampleAnnTip           = inj (Proxy @AnnTip)                        exampleAnnTip
+      , exampleLedgerState      = inj (Proxy @(Flip LedgerState EmptyMK))    exampleLedgerState
+      , exampleChainDepState    = inj (Proxy @WrapChainDepState)             exampleChainDepState
+      , exampleExtLedgerState   = inj (Proxy @(Flip ExtLedgerState EmptyMK)) exampleExtLedgerState
+      , exampleSlotNo           =                                            exampleSlotNo
+      , exampleLedgerTables     = inj (Proxy @WrapLedgerTables)              exampleLedgerTables
       }
     where
       inj ::
@@ -134,6 +143,37 @@ instance Inject Examples where
         => Proxy f -> Labelled a -> Labelled b
       inj p = fmap (fmap (inject' p startBounds idx))
 
+-- | This wrapper is used only in the 'Example' instance of 'Inject' so that we
+-- can use a type that matches the kind expected by 'inj'.
+newtype WrapLedgerTables blk = WrapLedgerTables ( LedgerTables (ExtLedgerState blk) ValuesMK )
+
+instance Inject WrapLedgerTables where
+  inject = injectWrapLedgerTables
+
+-- In the definition of 'inject' for 'WrapLedgerTables', if we want to add a
+-- type declaration to the local definition 'injectLedgerTables' we need to add
+-- a type declaration for 'inject' which requires enabling 'InstanceSigs' and
+-- introduces a compiler warning about 'CanHardFork xs' being a redundant
+-- constraint. By defining 'inject' in terms of 'injectWrapLedgerTables' we
+-- avoid this problem.
+injectWrapLedgerTables ::
+    forall x xs.
+    LedgerTablesCanHardFork xs
+   => Exactly xs History.Bound
+      -- ^ Start bound of each era
+   -> Index xs x
+   -> WrapLedgerTables x
+   -> WrapLedgerTables (HardForkBlock xs)
+injectWrapLedgerTables _startBounds idx (WrapLedgerTables (ExtLedgerStateTables lt)) =
+    WrapLedgerTables $ ExtLedgerStateTables $ injectLedgerTables lt
+  where
+    injectLedgerTables ::
+         (IsMapKind mk)
+      => LedgerTables (LedgerState                  x) mk
+      -> LedgerTables (LedgerState (HardForkBlock xs)) mk
+    injectLedgerTables = applyInjectLedgerTables
+                       $ projectNP idx hardForkInjectLedgerTables
+
 {-------------------------------------------------------------------------------
   Setup
 -------------------------------------------------------------------------------}
@@ -259,14 +299,14 @@ codecConfig =
       Shelley.ShelleyCodecConfig
 
 ledgerStateByron ::
-     LedgerState ByronBlock
-  -> LedgerState (CardanoBlock Crypto)
+     LedgerState ByronBlock mk
+  -> LedgerState (CardanoBlock Crypto) mk
 ledgerStateByron stByron =
     HardForkLedgerState $ HardForkState $ TZ cur
   where
     cur = State.Current {
           currentStart = History.initBound
-        , currentState = stByron
+        , currentState = Flip stByron
         }
 
 {-------------------------------------------------------------------------------

ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs

@@ -9,7 +9,9 @@
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE UndecidableInstances       #-}
+
 {-# OPTIONS_GHC -Wno-orphans #-}
+
 -- | 'Arbitrary' instances intended for serialisation roundtrip tests for
 -- 'CardanoBlock' and its related types.
 --
@@ -38,6 +40,7 @@ import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.Serialisation (Some (..))
 import           Ouroboros.Consensus.Protocol.Praos.Translate ()
 import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
+import           Ouroboros.Consensus.Shelley.HFEras ()
 import           Ouroboros.Consensus.Shelley.Ledger
 import           Ouroboros.Consensus.Shelley.Ledger.Block ()
 import           Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()