Parametrise the Shelley ledger over Value.

This PR demonstrates a way to parametrise the ledger over value. It
paves the way for overriding this type in subsequent eras, without
making any semantic changes to the Shelley ledger.

Functions in the ledger are now classfied into three groups:
- Those that remain universally quantified over eras.
- Those that have specific requirements on certain era-parametrised
types to work (e.g. that they can be serialised), and
- Those that are specific to Shelley.

There are two examples of the latter: `consumed` and `produced`.

The STS rules are likewise split in two:
- Those that remain universally quantified over eras.
- Those that are specific to Shelley.

The intention is that many will transition to the third (missing)
category, where the actual rules specify their exact requirements on the
era (see #1804 for an example of how to do this). This was not done
because I wanted to get this ready for the meeting and I didn't have
time.

This PR makes some very deliberate design choices:
- The 'Value' type family and any constraints thereon are _not_ lifted
into the 'Era' class. Such would imply universality over eras, which is
too strong a constraint. They would prevent us, for example, from adding to
the `Val` class in future eras, which seems quite plausible.
Furthermore, having more explicit constraints at the use site helps our
understanding of the code; it is much more obvious _when_ we are relying
on certain things, which can be a tool to spot bugs. Note that these
constraints do not propogate wildly, because in general they are
dispatched through the instantiation of the type family to a specific
type in a given era.
- It deliberately removes some instances (`Eq` for example) where it
seems there is no strong reason to have it. The presence of an `Eq`
instance everywhere has bitten us in the past, where for example we have
ended up calling `(==)` on a large part of state in the consensus
integration, which is an expensive operation. Honestly, I suspect I'll
have to add these back to get the tests working, since they rely on
them, but I think there's a decent case for making these instances
orphans in the testing code instead.

This is a *draft* PR for discussion. It does not yet touch the testing
code, and is inconsistent about various things (in particular, I stuck
`era ~ Shelley c` in a lot of places in a hurry).

shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal

@@ -18,9 +18,11 @@ flag development
 
 library
   exposed-modules:
+    Cardano.Ledger.Core
     Cardano.Ledger.Crypto
     Cardano.Ledger.Era
     Cardano.Ledger.Shelley
+    Cardano.Ledger.Val
     Shelley.Spec.Ledger.Address
     Shelley.Spec.Ledger.Address.Bootstrap
     Shelley.Spec.Ledger.API
@@ -76,7 +78,6 @@ library
     Shelley.Spec.Ledger.Tx
     Shelley.Spec.Ledger.TxBody
     Shelley.Spec.Ledger.UTxO
-    Cardano.Ledger.Val
   other-modules:     Shelley.Spec.Ledger.API.Mempool
                      Shelley.Spec.Ledger.API.Wallet
                      Shelley.Spec.Ledger.API.Types

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Core.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | This module defines core type families which we know to vary from era to
+-- era.
+--
+-- Families in this module should be indexed on era.
+--
+-- It is intended for qualified import:
+-- > import qualified Cardano.Ledger.Core as Core
+module Cardano.Ledger.Core
+  ( -- * Compactible
+    Compactible (..),
+    Compact (..),
+    ValType,
+    Value,
+  )
+where
+
+import Cardano.Binary (FromCBOR (..), ToCBOR (..))
+import Cardano.Prelude (NFData, NoUnexpectedThunks (..))
+import Data.Kind (Type)
+import Data.Typeable (Typeable)
+
+class
+  ( Compactible (Value era),
+    Eq (Value era),
+    FromCBOR (CompactForm (Value era)),
+    FromCBOR (Value era),
+    NFData (Value era),
+    NoUnexpectedThunks (Value era),
+    Show (Value era),
+    ToCBOR (CompactForm (Value era)),
+    ToCBOR (Value era),
+    Typeable (Value era)
+  ) =>
+  ValType era
+
+type family Value era :: Type
+
+-- | A value is something which quantifies a transaction output.
+
+--------------------------------------------------------------------------------
+
+-- * Compactible
+
+--
+-- Certain types may have a "presentation" form and a more compact
+-- representation that allows for more efficient memory usage. In this case,
+-- one should make instances of the 'Compactible' class for them.
+--------------------------------------------------------------------------------
+
+class Compactible a where
+  data CompactForm a :: Type
+  toCompact :: a -> CompactForm a
+  fromCompact :: CompactForm a -> a
+
+newtype Compact a = Compact {unCompact :: a}
+
+instance
+  (Typeable a, Compactible a, ToCBOR (CompactForm a)) =>
+  ToCBOR (Compact a)
+  where
+  toCBOR = toCBOR . toCompact . unCompact
+
+instance
+  (Typeable a, Compactible a, FromCBOR (CompactForm a)) =>
+  FromCBOR (Compact a)
+  where
+  fromCBOR = Compact . fromCompact <$> fromCBOR
+
+-- TODO: consider if this is better the other way around
+instance (Eq a, Compactible a) => Eq (CompactForm a) where
+  a == b = fromCompact a == fromCompact b

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs

@@ -6,6 +6,9 @@ module Cardano.Ledger.Shelley where
 
 import qualified Cardano.Ledger.Crypto as CryptoClass
 import Cardano.Ledger.Era
+import Cardano.Ledger.Core (Value, ValType)
+import Shelley.Spec.Ledger.Coin (Coin)
+
 
 --------------------------------------------------------------------------------
 -- Shelley Era
@@ -15,3 +18,8 @@ data Shelley c
 
 instance CryptoClass.Crypto c => Era (Shelley c) where
   type Crypto (Shelley c) = c
+
+type instance Value (Shelley c) = Coin
+
+instance ValType (Shelley c)
+

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Val.hs

@@ -36,28 +36,15 @@ module Cardano.Ledger.Val
   )
 where
 
-import Cardano.Binary
-  ( FromCBOR (..),
-    ToCBOR (..),
-  )
-import Cardano.Prelude (NFData (), NoUnexpectedThunks (..))
 import Data.Group (Abelian)
 import Data.PartialOrd hiding ((==))
 import qualified Data.PartialOrd
-import Data.Typeable (Typeable)
 import Shelley.Spec.Ledger.Coin (Coin (..))
 
 class
   ( Abelian t,
     Eq t,
-    PartialOrd t,
-    -- Do we really need these?
-    Show t,
-    Typeable t,
-    NFData t,
-    NoUnexpectedThunks t,
-    ToCBOR t,
-    FromCBOR t
+    PartialOrd t
   ) =>
   Val t
   where

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Mempool.hs

@@ -1,8 +1,12 @@
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Interface to the Shelley ledger for the purposes of managing a Shelley
 -- mempool.
@@ -18,7 +22,9 @@ module Shelley.Spec.Ledger.API.Mempool
 where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
-import Cardano.Ledger.Era
+import Cardano.Ledger.Era (Era)
+import qualified Cardano.Ledger.Core as Core
+import qualified Cardano.Ledger.Val as Val
 import Control.Arrow (left)
 import Control.Monad.Except
 import Control.Monad.Trans.Reader (runReader)
@@ -77,23 +83,34 @@ mkMempoolState LedgerState.NewEpochState {LedgerState.nesEs} =
   LedgerState.esLState nesEs
 
 data ApplyTxError era = ApplyTxError [PredicateFailure (LEDGERS era)]
-  deriving (Eq, Show)
+
+deriving stock instance
+  (Eq (PredicateFailure (LEDGERS era))) =>
+  Eq (ApplyTxError era)
+
+deriving stock instance
+  (Show (PredicateFailure (LEDGERS era))) =>
+  Show (ApplyTxError era)
 
 instance
-  (Typeable era, Era era) =>
+  (Typeable era, Era era, Core.ValType era) =>
   ToCBOR (ApplyTxError era)
   where
   toCBOR (ApplyTxError es) = toCBOR es
 
 instance
-  (Era era) =>
+  (Era era,
+   Core.ValType era
+  ) =>
   FromCBOR (ApplyTxError era)
   where
   fromCBOR = ApplyTxError <$> fromCBOR
 
 applyTxs ::
   forall era m.
   ( Era era,
+    Core.ValType era,
+    Val.Val (Core.Value era),
     MonadError (ApplyTxError era) m,
     DSignable era (Hash era (Tx.TxBody era))
   ) =>

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Protocol.hs

@@ -1,11 +1,14 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE StrictData #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Integration between the Shelley ledger and its corresponding (Transitional
 -- Praos) protocol.
@@ -33,6 +36,8 @@ import Cardano.Crypto.KES.Class
 import Cardano.Crypto.VRF.Class
 import Cardano.Ledger.Crypto hiding (Crypto)
 import Cardano.Ledger.Era (Crypto, Era)
+import qualified Cardano.Ledger.Core as Core
+import qualified Cardano.Ledger.Val as Val
 import Cardano.Prelude (NoUnexpectedThunks (..))
 import Control.Arrow (left, right)
 import Control.Monad.Except
@@ -174,7 +179,14 @@ currentLedgerView = view
 
 newtype FutureLedgerViewError era
   = FutureLedgerViewError [PredicateFailure (TICK era)]
-  deriving (Eq, Show)
+
+deriving stock instance
+  (Eq (PredicateFailure (TICK era))) =>
+  Eq (FutureLedgerViewError era)
+
+deriving stock instance
+  (Show (PredicateFailure (TICK era))) =>
+  Show (FutureLedgerViewError era)
 
 -- | Anachronistic ledger view
 --
@@ -184,6 +196,8 @@ newtype FutureLedgerViewError era
 futureLedgerView ::
   forall era m.
   ( Era era,
+    Core.ValType era,
+    Val.Val (Core.Value era),
     MonadError (FutureLedgerViewError era) m
   ) =>
   Globals ->

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs

@@ -1,8 +1,12 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Interface to the block validation and chain extension logic in the Shelley
 -- API.
@@ -17,12 +21,18 @@ module Shelley.Spec.Ledger.API.Validation
   )
 where
 
-import Cardano.Ledger.Era
+import qualified Cardano.Ledger.Core as Core
+import Cardano.Ledger.Era (Era)
+import qualified Cardano.Ledger.Val as Val
 import Cardano.Prelude (NoUnexpectedThunks (..))
 import Control.Arrow (left, right)
 import Control.Monad.Except
 import Control.Monad.Trans.Reader (runReader)
-import Control.State.Transition.Extended (TRC (..), applySTS, reapplySTS)
+import Control.State.Transition.Extended
+  ( TRC (..),
+    applySTS,
+    reapplySTS,
+  )
 import GHC.Generics (Generic)
 import Shelley.Spec.Ledger.BaseTypes (Globals (..))
 import Shelley.Spec.Ledger.BlockChain
@@ -68,17 +78,30 @@ mkBbodyEnv
 
 newtype TickTransitionError era
   = TickTransitionError [STS.PredicateFailure (STS.TICK era)]
-  deriving (Eq, Show, Generic)
+  deriving (Generic)
+
+instance
+  (NoUnexpectedThunks (STS.PredicateFailure (STS.TICK era))) =>
+  NoUnexpectedThunks (TickTransitionError era)
 
-instance NoUnexpectedThunks (TickTransitionError era)
+deriving stock instance
+  (Eq (STS.PredicateFailure (STS.TICK era))) =>
+  Eq (TickTransitionError era)
+
+deriving stock instance
+  (Show (STS.PredicateFailure (STS.TICK era))) =>
+  Show (TickTransitionError era)
 
 -- | Apply the header level ledger transition.
 --
 -- This handles checks and updates that happen on a slot tick, as well as a few
 -- header level checks, such as size constraints.
 applyTickTransition ::
   forall era.
-  (Era era) =>
+  ( Era era,
+    Core.ValType era,
+    Val.Val (Core.Value era)
+  ) =>
   Globals ->
   ShelleyState era ->
   SlotNo ->
@@ -93,14 +116,26 @@ applyTickTransition globals state hdr =
 
 newtype BlockTransitionError era
   = BlockTransitionError [STS.PredicateFailure (STS.BBODY era)]
-  deriving (Eq, Generic, Show)
+  deriving (Generic)
+
+deriving stock instance
+  (Eq (STS.PredicateFailure (STS.BBODY era))) =>
+  Eq (BlockTransitionError era)
+
+deriving stock instance
+  (Show (STS.PredicateFailure (STS.BBODY era))) =>
+  Show (BlockTransitionError era)
 
-instance (Era era) => NoUnexpectedThunks (BlockTransitionError era)
+instance
+  (NoUnexpectedThunks (STS.PredicateFailure (STS.BBODY era))) =>
+  NoUnexpectedThunks (BlockTransitionError era)
 
 -- | Apply the block level ledger transition.
 applyBlockTransition ::
   forall era m.
   ( Era era,
+    Core.ValType era,
+    Val.Val (Core.Value era),
     MonadError (BlockTransitionError era) m,
     DSignable era (Hash era (Tx.TxBody era))
   ) =>
@@ -136,6 +171,8 @@ applyBlockTransition globals state blk =
 reapplyBlockTransition ::
   forall era.
   ( Era era,
+    Core.ValType era,
+    Val.Val (Core.Value era),
     DSignable era (Hash era (Tx.TxBody era))
   ) =>
   Globals ->