diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 2911c26941..70e5f3ff76 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} @@ -24,7 +23,6 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool ( , SL.ApplyTxError (..) , TxId (..) , Validated (..) - , WithTop (..) , fixedBlockBodyOverhead , mkShelleyTx , mkShelleyValidatedTx @@ -55,8 +53,7 @@ import Control.Monad.Except (Except) import Control.Monad.Identity (Identity (..)) import Data.DerivingVia (InstantiatedAt (..)) import Data.Foldable (toList) -import Data.Measure (BoundedMeasure, Measure) -import qualified Data.Measure as Measure +import Data.Measure (Measure) import Data.Typeable (Typeable) import GHC.Generics (Generic) import GHC.Natural (Natural) @@ -322,17 +319,17 @@ instance ( ShelleyCompatible p (AlonzoEra c) data AlonzoMeasure = AlonzoMeasure { byteSize :: !ByteSize - , exUnits :: !(ExUnits' (WithTop Natural)) + , exUnits :: !(ExUnits' Natural) } deriving stock (Eq, Generic, Show) deriving anyclass (NoThunks) - deriving (BoundedMeasure, Measure) + deriving (Measure) via (InstantiatedAt Generic AlonzoMeasure) instance HasByteSize AlonzoMeasure where txMeasureByteSize = byteSize -fromExUnits :: ExUnits -> ExUnits' (WithTop Natural) -fromExUnits = fmap NotTop . unWrapExUnits +fromExUnits :: ExUnits -> ExUnits' Natural +fromExUnits = unWrapExUnits txMeasureAlonzo :: forall proto era. @@ -369,7 +366,7 @@ data ConwayMeasure = ConwayMeasure { , refScriptsSize :: !ByteSize } deriving stock (Eq, Generic, Show) deriving anyclass (NoThunks) - deriving (BoundedMeasure, Measure) + deriving (Measure) via (InstantiatedAt Generic ConwayMeasure) instance HasByteSize ConwayMeasure where @@ -396,39 +393,3 @@ instance ( ShelleyCompatible p (ConwayEra c) -- For post-Conway eras, this will become a protocol parameter. SL.maxRefScriptSizePerBlock } - -{------------------------------------------------------------------------------- - WithTop --------------------------------------------------------------------------------} - --- | Add a unique top element to a lattice. --- --- TODO This should be relocated to `cardano-base:Data.Measure'. -data WithTop a = NotTop !a | Top - deriving (Eq, Generic, Show) - deriving anyclass (NoThunks) - -instance Ord a => Ord (WithTop a) where - compare = curry $ \case - (Top , Top ) -> EQ - (Top , _ ) -> GT - (_ , Top ) -> LT - (NotTop l, NotTop r) -> compare l r - -instance Measure a => Measure (WithTop a) where - zero = NotTop Measure.zero - plus = curry $ \case - (Top , _ ) -> Top - (_ , Top ) -> Top - (NotTop l, NotTop r) -> NotTop $ Measure.plus l r - min = curry $ \case - (Top , r ) -> r - (l , Top ) -> l - (NotTop l, NotTop r) -> NotTop $ Measure.min l r - max = curry $ \case - (Top , _ ) -> Top - (_ , Top ) -> Top - (NotTop l, NotTop r) -> NotTop $ Measure.max l r - -instance Measure a => BoundedMeasure (WithTop a) where - maxBound = Top diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs index 9cb572d1ce..4ed86d707e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs @@ -6,7 +6,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork (CanHardFork (..)) where -import Data.Measure (BoundedMeasure) +import Data.Measure (Measure) import Data.SOP.Constraint import Data.SOP.Functors (Product2) import Data.SOP.InPairs (InPairs, RequiringBoth) @@ -31,10 +31,10 @@ import Ouroboros.Consensus.TypeFamilyWrappers class ( All SingleEraBlock xs , Typeable xs , IsNonEmpty xs - , BoundedMeasure (HardForkTxMeasure xs) - , HasByteSize (HardForkTxMeasure xs) - , NoThunks (HardForkTxMeasure xs) - , Show (HardForkTxMeasure xs) + , Measure (HardForkTxMeasure xs) + , HasByteSize (HardForkTxMeasure xs) + , NoThunks (HardForkTxMeasure xs) + , Show (HardForkTxMeasure xs) ) => CanHardFork xs where -- | A measure that can accurately represent the 'TxMeasure' of any era. -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs index dfb497b408..6bf334242b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs @@ -25,7 +25,7 @@ import Control.Monad.Except import Data.ByteString.Short (ShortByteString) import Data.DerivingVia (InstantiatedAt (..)) import Data.Kind (Type) -import Data.Measure (BoundedMeasure, Measure) +import Data.Measure (Measure) import Data.Word (Word32) import GHC.Stack (HasCallStack) import NoThunks.Class @@ -165,10 +165,10 @@ class HasTxs blk where -- state). In future eras (starting with Alonzo) this measure was a bit more -- complex as it had to take other factors into account (like execution units). -- For details please see the individual instances for the TxLimits. -class ( BoundedMeasure (TxMeasure blk) - , HasByteSize (TxMeasure blk) - , NoThunks (TxMeasure blk) - , Show (TxMeasure blk) +class ( Measure (TxMeasure blk) + , HasByteSize (TxMeasure blk) + , NoThunks (TxMeasure blk) + , Show (TxMeasure blk) ) => TxLimits blk where -- | The (possibly multi-dimensional) size of a transaction in a block. type TxMeasure blk @@ -207,7 +207,7 @@ class ( BoundedMeasure (TxMeasure blk) newtype ByteSize = ByteSize { unByteSize :: Word32 } deriving stock (Show) deriving newtype (Eq, Ord) - deriving newtype (BoundedMeasure, Measure) + deriving newtype (Measure) deriving newtype (NFData) deriving (Monoid, Semigroup) via (InstantiatedAt Measure ByteSize) deriving (NoThunks) via OnlyCheckWhnfNamed "ByteSize" ByteSize