fixup! Don't define preferCandidate in terms of Ord

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs

@@ -105,7 +105,7 @@ newtype PerEraConsensusConfig  xs = PerEraConsensusConfig  { getPerEraConsensusC
 newtype PerEraLedgerConfig     xs = PerEraLedgerConfig     { getPerEraLedgerConfig     :: NP WrapPartialLedgerConfig    xs }
 newtype PerEraStorageConfig    xs = PerEraStorageConfig    { getPerEraStorageConfig    :: NP StorageConfig              xs }
 
-newtype PerEraProtocolParams  xs = PerEraProtocolParams  { getPerEraProtocolParams  :: NP ProtocolParams             xs }
+newtype PerEraProtocolParams   xs = PerEraProtocolParams   { getPerEraProtocolParams   :: NP ProtocolParams             xs }
 
 {-------------------------------------------------------------------------------
   Values for /some/ eras

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol/ChainSel.hs

@@ -44,9 +44,10 @@ data AcrossEraSelection :: Type -> Type -> Type where
   -- chains even across eras, as the chain ordering is fully captured by
   -- 'SelectView' and its 'ChainOrder' instance.
   --
-  -- We use the 'ChainOrderConfig' of the 'SelectView' in the newer era when
-  -- invoking 'compareChains'. (We could also make this choice configurable
-  -- here.)
+  -- We use the 'ChainOrderConfig' of the 'SelectView' in the newer era (with
+  -- the intuition that newer eras are generally "preferred") when invoking
+  -- 'compareChains'. However, this choice is arbitrary; we could also make it
+  -- configurable here.
   CompareSameSelectView ::
        SelectView (BlockProtocol x) ~ SelectView (BlockProtocol y)
     => AcrossEraSelection x y
@@ -80,7 +81,8 @@ acrossEras ::
   => FlipArgs
   -> AcrossEraMode cfg a
   -> cfg                        blk'
-     -- ^ The configuration corresponding to the later block/era.
+     -- ^ The configuration corresponding to the later block/era, also see
+     -- 'CompareSameSelectView'.
   -> WithBlockNo WrapSelectView blk
   -> WithBlockNo WrapSelectView blk'
   -> AcrossEraSelection blk blk'
@@ -101,47 +103,48 @@ acrossEras flipArgs mode cfg
       FlipArgs -> flip
 
 acrossEraSelection ::
+     forall xs cfg a.
      All SingleEraBlock              xs
   => AcrossEraMode cfg a
   -> NP cfg                          xs
   -> Tails AcrossEraSelection        xs
   -> WithBlockNo (NS WrapSelectView) xs
   -> WithBlockNo (NS WrapSelectView) xs
   -> a
-acrossEraSelection (mode :: AcrossEraMode cfg a) = \cfg ffs l r ->
-    goLeft cfg ffs (distribBlockNo l, distribBlockNo r)
+acrossEraSelection mode = \cfg ffs l r ->
+    goBoth cfg ffs (distribBlockNo l, distribBlockNo r)
   where
-    goLeft ::
-         All SingleEraBlock                xs
-      => NP cfg                            xs
-      -> Tails AcrossEraSelection          xs
-      -> ( NS (WithBlockNo WrapSelectView) xs
-         , NS (WithBlockNo WrapSelectView) xs
+    goBoth ::
+         All SingleEraBlock                xs'
+      => NP cfg                            xs'
+      -> Tails AcrossEraSelection          xs'
+      -> ( NS (WithBlockNo WrapSelectView) xs'
+         , NS (WithBlockNo WrapSelectView) xs'
          )
       -> a
-    goLeft _             TNil            = \(a, _) -> case a of {}
-    goLeft (cfg :* cfgs) (TCons fs ffs') = \case
+    goBoth _             TNil            = \(a, _) -> case a of {}
+    goBoth (cfg :* cfgs) (TCons fs ffs') = \case
         (Z a, Z b) -> cmp (dropBlockNo a) (dropBlockNo b)
           where
             cmp = applyAcrossEraMode cfg unwrapChainOrderConfig mode
-        (Z a, S b) -> goRight KeepArgs a cfgs fs b
-        (S a, Z b) -> goRight FlipArgs b cfgs fs a
-        (S a, S b) -> goLeft cfgs ffs' (a, b)
+        (Z a, S b) -> goOne KeepArgs a cfgs fs b
+        (S a, Z b) -> goOne FlipArgs b cfgs fs a
+        (S a, S b) -> goBoth cfgs ffs' (a, b)
 
-    goRight ::
-         forall x xs. (SingleEraBlock x, All SingleEraBlock xs)
+    goOne ::
+         forall x xs'. (SingleEraBlock x, All SingleEraBlock xs')
       => FlipArgs
       -> WithBlockNo WrapSelectView x
-      -> NP cfg                          xs
-      -> NP (AcrossEraSelection     x)   xs
-      -> NS (WithBlockNo WrapSelectView) xs
+      -> NP cfg                          xs'
+      -> NP (AcrossEraSelection     x)   xs'
+      -> NS (WithBlockNo WrapSelectView) xs'
       -> a
-    goRight flipArgs a = go
+    goOne flipArgs a = go
       where
-        go :: forall xs'. All SingleEraBlock  xs'
-           => NP cfg                          xs'
-           -> NP (AcrossEraSelection x)       xs'
-           -> NS (WithBlockNo WrapSelectView) xs'
+        go :: forall xs''. All SingleEraBlock xs''
+           => NP cfg                          xs''
+           -> NP (AcrossEraSelection x)       xs''
+           -> NS (WithBlockNo WrapSelectView) xs''
            -> a
         go _             Nil          b  = case b of {}
         go (cfg :* _   ) (f :* _)  (Z b) = acrossEras flipArgs mode cfg a b f

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/Abstract.hs

@@ -186,8 +186,8 @@ class ( Show (ChainDepState   p)
 -- for prioritization. For example, this is used in ChainSel during initial
 -- chain selection or when blocks arrive out of order (not the case when the
 -- node is caught up), or in the BlockFetch decision logic.
-class Ord a => ChainOrder a where
-  type ChainOrderConfig a :: Type
+class Ord sv => ChainOrder sv where
+  type ChainOrderConfig sv :: Type
 
   -- | Compare a candidate chain to our own.
   --
@@ -217,25 +217,25 @@ class Ord a => ChainOrder a where
   --  [__Chain extension precedence__]: @a@ must contain the underlying block
   --      number, and use this as the primary way of comparing chains.
   --
-  --      Suppose that we have a function @blockNo :: a -> Natural@. Then for
+  --      Suppose that we have a function @blockNo :: sv -> Natural@. Then for
   --      all @a, b@ with @blockNo a < blockNo b@ we must have @a ⊏ b@.
   --
   --      Intuitively, this means that only the logic for breaking ties between
   --      chains with equal block number is customizable via this class.
   preferCandidate ::
-       ChainOrderConfig a
-    -> a -- ^ Tip of our chain
-    -> a -- ^ Tip of the candidate
+       ChainOrderConfig sv
+    -> sv -- ^ Tip of our chain
+    -> sv -- ^ Tip of the candidate
     -> Bool
 
 -- | A @DerivingVia@ helper to implement 'preferCandidate' in terms of the 'Ord'
 -- instance.
-newtype SimpleChainOrder a = SimpleChainOrder a
+newtype SimpleChainOrder sv = SimpleChainOrder sv
   deriving newtype (Eq, Ord)
 
-instance Ord a => ChainOrder (SimpleChainOrder a) where
-  type ChainOrderConfig (SimpleChainOrder a) = ()
+instance Ord sv => ChainOrder (SimpleChainOrder sv) where
+  type ChainOrderConfig (SimpleChainOrder sv) = ()
 
-  preferCandidate _cfg ours cand = cand > ours
+  preferCandidate _cfg ours cand = ours < cand
 
 deriving via SimpleChainOrder BlockNo instance ChainOrder BlockNo

ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs

@@ -178,7 +178,8 @@ The `preferCandidate` function in `Ouroboros.Consensus.Protocol.Abstract`
 demonstrates how this is used.
 
 Note that instantiations of `ConsensusProtocol` for some protocol `p`
-consequently requires `Ord (SelectView p)`.
+consequently requires `ChainOrder (SelectView p)` (which in particular requires
+`Ord (SelectView p)`.
 
 For `SP` we will use only `BlockNo` - to implement the simplest rule of
 preferring longer chains to shorter chains.