{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Ouroboros.Consensus.Peras.Weight
(
PerasWeightSnapshot
, emptyPerasWeightSnapshot
, mkPerasWeightSnapshot
, perasWeightSnapshotToList
, addToPerasWeightSnapshot
, prunePerasWeightSnapshot
, weightBoostOfPoint
, weightBoostOfFragment
, totalWeightOfFragment
) where
import Data.Foldable as Foldable (foldl')
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import GHC.Generics (Generic)
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
newtype PerasWeightSnapshot blk = PerasWeightSnapshot
{ forall blk. PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
getPerasWeightSnapshot :: Map (Point blk) PerasWeight
}
deriving stock PerasWeightSnapshot blk -> PerasWeightSnapshot blk -> Bool
(PerasWeightSnapshot blk -> PerasWeightSnapshot blk -> Bool)
-> (PerasWeightSnapshot blk -> PerasWeightSnapshot blk -> Bool)
-> Eq (PerasWeightSnapshot blk)
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> PerasWeightSnapshot blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> PerasWeightSnapshot blk -> Bool
== :: PerasWeightSnapshot blk -> PerasWeightSnapshot blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> PerasWeightSnapshot blk -> Bool
/= :: PerasWeightSnapshot blk -> PerasWeightSnapshot blk -> Bool
Eq
deriving (forall x.
PerasWeightSnapshot blk -> Rep (PerasWeightSnapshot blk) x)
-> (forall x.
Rep (PerasWeightSnapshot blk) x -> PerasWeightSnapshot blk)
-> Generic (PerasWeightSnapshot blk)
forall x.
Rep (PerasWeightSnapshot blk) x -> PerasWeightSnapshot blk
forall x.
PerasWeightSnapshot blk -> Rep (PerasWeightSnapshot blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (PerasWeightSnapshot blk) x -> PerasWeightSnapshot blk
forall blk x.
PerasWeightSnapshot blk -> Rep (PerasWeightSnapshot blk) x
$cfrom :: forall blk x.
PerasWeightSnapshot blk -> Rep (PerasWeightSnapshot blk) x
from :: forall x.
PerasWeightSnapshot blk -> Rep (PerasWeightSnapshot blk) x
$cto :: forall blk x.
Rep (PerasWeightSnapshot blk) x -> PerasWeightSnapshot blk
to :: forall x.
Rep (PerasWeightSnapshot blk) x -> PerasWeightSnapshot blk
Generic
deriving newtype Context -> PerasWeightSnapshot blk -> IO (Maybe ThunkInfo)
Proxy (PerasWeightSnapshot blk) -> String
(Context -> PerasWeightSnapshot blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasWeightSnapshot blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasWeightSnapshot blk) -> String)
-> NoThunks (PerasWeightSnapshot blk)
forall blk.
StandardHash blk =>
Context -> PerasWeightSnapshot blk -> IO (Maybe ThunkInfo)
forall blk.
StandardHash blk =>
Proxy (PerasWeightSnapshot blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> PerasWeightSnapshot blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasWeightSnapshot blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> PerasWeightSnapshot blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasWeightSnapshot blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk.
StandardHash blk =>
Proxy (PerasWeightSnapshot blk) -> String
showTypeOf :: Proxy (PerasWeightSnapshot blk) -> String
NoThunks
instance StandardHash blk => Show (PerasWeightSnapshot blk) where
show :: PerasWeightSnapshot blk -> String
show = [(Point blk, PerasWeight)] -> String
forall a. Show a => a -> String
show ([(Point blk, PerasWeight)] -> String)
-> (PerasWeightSnapshot blk -> [(Point blk, PerasWeight)])
-> PerasWeightSnapshot blk
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasWeightSnapshot blk -> [(Point blk, PerasWeight)]
forall blk. PerasWeightSnapshot blk -> [(Point blk, PerasWeight)]
perasWeightSnapshotToList
emptyPerasWeightSnapshot :: PerasWeightSnapshot blk
emptyPerasWeightSnapshot :: forall blk. PerasWeightSnapshot blk
emptyPerasWeightSnapshot = Map (Point blk) PerasWeight -> PerasWeightSnapshot blk
forall blk. Map (Point blk) PerasWeight -> PerasWeightSnapshot blk
PerasWeightSnapshot Map (Point blk) PerasWeight
forall k a. Map k a
Map.empty
mkPerasWeightSnapshot ::
StandardHash blk =>
[(Point blk, PerasWeight)] ->
PerasWeightSnapshot blk
mkPerasWeightSnapshot :: forall blk.
StandardHash blk =>
[(Point blk, PerasWeight)] -> PerasWeightSnapshot blk
mkPerasWeightSnapshot =
(PerasWeightSnapshot blk
-> (Point blk, PerasWeight) -> PerasWeightSnapshot blk)
-> PerasWeightSnapshot blk
-> [(Point blk, PerasWeight)]
-> PerasWeightSnapshot blk
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl'
(\PerasWeightSnapshot blk
s (Point blk
pt, PerasWeight
weight) -> Point blk
-> PerasWeight
-> PerasWeightSnapshot blk
-> PerasWeightSnapshot blk
forall blk.
StandardHash blk =>
Point blk
-> PerasWeight
-> PerasWeightSnapshot blk
-> PerasWeightSnapshot blk
addToPerasWeightSnapshot Point blk
pt PerasWeight
weight PerasWeightSnapshot blk
s)
PerasWeightSnapshot blk
forall blk. PerasWeightSnapshot blk
emptyPerasWeightSnapshot
perasWeightSnapshotToList :: PerasWeightSnapshot blk -> [(Point blk, PerasWeight)]
perasWeightSnapshotToList :: forall blk. PerasWeightSnapshot blk -> [(Point blk, PerasWeight)]
perasWeightSnapshotToList = Map (Point blk) PerasWeight -> [(Point blk, PerasWeight)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map (Point blk) PerasWeight -> [(Point blk, PerasWeight)])
-> (PerasWeightSnapshot blk -> Map (Point blk) PerasWeight)
-> PerasWeightSnapshot blk
-> [(Point blk, PerasWeight)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
forall blk. PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
getPerasWeightSnapshot
addToPerasWeightSnapshot ::
StandardHash blk =>
Point blk ->
PerasWeight ->
PerasWeightSnapshot blk ->
PerasWeightSnapshot blk
addToPerasWeightSnapshot :: forall blk.
StandardHash blk =>
Point blk
-> PerasWeight
-> PerasWeightSnapshot blk
-> PerasWeightSnapshot blk
addToPerasWeightSnapshot Point blk
pt PerasWeight
weight =
Map (Point blk) PerasWeight -> PerasWeightSnapshot blk
forall blk. Map (Point blk) PerasWeight -> PerasWeightSnapshot blk
PerasWeightSnapshot (Map (Point blk) PerasWeight -> PerasWeightSnapshot blk)
-> (PerasWeightSnapshot blk -> Map (Point blk) PerasWeight)
-> PerasWeightSnapshot blk
-> PerasWeightSnapshot blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PerasWeight -> PerasWeight -> PerasWeight)
-> Point blk
-> PerasWeight
-> Map (Point blk) PerasWeight
-> Map (Point blk) PerasWeight
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
(<>) Point blk
pt PerasWeight
weight (Map (Point blk) PerasWeight -> Map (Point blk) PerasWeight)
-> (PerasWeightSnapshot blk -> Map (Point blk) PerasWeight)
-> PerasWeightSnapshot blk
-> Map (Point blk) PerasWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
forall blk. PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
getPerasWeightSnapshot
prunePerasWeightSnapshot ::
SlotNo ->
PerasWeightSnapshot blk ->
PerasWeightSnapshot blk
prunePerasWeightSnapshot :: forall blk.
SlotNo -> PerasWeightSnapshot blk -> PerasWeightSnapshot blk
prunePerasWeightSnapshot SlotNo
slot =
Map (Point blk) PerasWeight -> PerasWeightSnapshot blk
forall blk. Map (Point blk) PerasWeight -> PerasWeightSnapshot blk
PerasWeightSnapshot (Map (Point blk) PerasWeight -> PerasWeightSnapshot blk)
-> (PerasWeightSnapshot blk -> Map (Point blk) PerasWeight)
-> PerasWeightSnapshot blk
-> PerasWeightSnapshot blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point blk -> Bool)
-> Map (Point blk) PerasWeight -> Map (Point blk) PerasWeight
forall k a. (k -> Bool) -> Map k a -> Map k a
Map.dropWhileAntitone Point blk -> Bool
forall blk. Point blk -> Bool
isTooOld (Map (Point blk) PerasWeight -> Map (Point blk) PerasWeight)
-> (PerasWeightSnapshot blk -> Map (Point blk) PerasWeight)
-> PerasWeightSnapshot blk
-> Map (Point blk) PerasWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
forall blk. PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
getPerasWeightSnapshot
where
isTooOld :: Point blk -> Bool
isTooOld :: forall blk. Point blk -> Bool
isTooOld Point blk
pt = Point blk -> WithOrigin SlotNo
forall {k} (block :: k). Point block -> WithOrigin SlotNo
pointSlot Point blk
pt WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slot
weightBoostOfPoint ::
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint :: forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint (PerasWeightSnapshot Map (Point blk) PerasWeight
weightByPoint) Point blk
pt =
PerasWeight
-> Point blk -> Map (Point blk) PerasWeight -> PerasWeight
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault PerasWeight
forall a. Monoid a => a
mempty Point blk
pt Map (Point blk) PerasWeight
weightByPoint
weightBoostOfFragment ::
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk ->
AnchoredFragment h ->
PerasWeight
weightBoostOfFragment :: forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot blk
weightSnap AnchoredFragment h
frag
| Map (Point blk) PerasWeight -> Bool
forall k a. Map k a -> Bool
Map.null (Map (Point blk) PerasWeight -> Bool)
-> Map (Point blk) PerasWeight -> Bool
forall a b. (a -> b) -> a -> b
$ PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
forall blk. PerasWeightSnapshot blk -> Map (Point blk) PerasWeight
getPerasWeightSnapshot PerasWeightSnapshot blk
weightSnap =
PerasWeight
forall a. Monoid a => a
mempty
| Bool
otherwise =
(h -> PerasWeight) -> [h] -> PerasWeight
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
(PerasWeightSnapshot blk -> Point blk -> PerasWeight
forall blk.
StandardHash blk =>
PerasWeightSnapshot blk -> Point blk -> PerasWeight
weightBoostOfPoint PerasWeightSnapshot blk
weightSnap (Point blk -> PerasWeight) -> (h -> Point blk) -> h -> PerasWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Point h -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point h -> Point blk) -> (h -> Point h) -> h -> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h -> Point h
forall block. HasHeader block => block -> Point block
blockPoint)
(AnchoredFragment h -> [h]
forall v a b. AnchoredSeq v a b -> [b]
AF.toOldestFirst AnchoredFragment h
frag)
totalWeightOfFragment ::
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk ->
AnchoredFragment h ->
PerasWeight
totalWeightOfFragment :: forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
totalWeightOfFragment PerasWeightSnapshot blk
weightSnap AnchoredFragment h
frag =
PerasWeight
weightLength PerasWeight -> PerasWeight -> PerasWeight
forall a. Semigroup a => a -> a -> a
<> PerasWeight
weightBoost
where
weightLength :: PerasWeight
weightLength = Word64 -> PerasWeight
PerasWeight (Word64 -> PerasWeight) -> Word64 -> PerasWeight
forall a b. (a -> b) -> a -> b
$ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ AnchoredFragment h -> Int
forall v a b. Anchorable v a b => AnchoredSeq v a b -> Int
AF.length AnchoredFragment h
frag
weightBoost :: PerasWeight
weightBoost = PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
forall blk h.
(StandardHash blk, HasHeader h, HeaderHash blk ~ HeaderHash h) =>
PerasWeightSnapshot blk -> AnchoredFragment h -> PerasWeight
weightBoostOfFragment PerasWeightSnapshot blk
weightSnap AnchoredFragment h
frag