consensus: no longer need BoundedMeasure, Measure suffices

Author: nfrisby

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs

@@ -24,7 +24,6 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool (
   , SL.ApplyTxError (..)
   , TxId (..)
   , Validated (..)
-  , WithTop (..)
   , fixedBlockBodyOverhead
   , mkShelleyTx
   , mkShelleyValidatedTx
@@ -55,7 +54,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           Data.Measure (Measure)
 import qualified Data.Measure as Measure
 import           Data.Typeable (Typeable)
 import           GHC.Generics (Generic)
@@ -322,17 +321,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 +368,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 +395,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

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
   type HardForkTxMeasure xs
 

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