{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This module isolates all the types and functionality around
-- Governance Proposals.
--
-- It is important to note that there are two sets of state that we
-- maintain around proposals and their enactment. One is processed
-- with transactions (@`Proposals`@) and another at the epoch boundary
-- (@`PrevGovActionIds`@, @`DRepPulser`@). These two sets work together:
-- the incoming proposals and votes are collected continuously in the
-- state that lives with transaction processing, and at each epoch
-- boundary a snapshot of this state is taken to perform pulsing
-- computations on - after it has been adjusted (the proposals are
-- enacted or expired) based on the result of the previous pulsing
-- computaiion.
--
-- Below is a typical timeline of the processing of these states.
--
-- 1. Epoch n: Proposals and votes are continuously collected from
-- incoming transactions into @`Proposals`@
--
-- 2. Epoch n boundary: The @`DRepPulser`@ contains all proposals and
-- votes from epoch (n - 1). Its calculation is completed, ratified
-- and enacted or expired. Ratification and enactment do not affect
-- @`Proposals`@ directly. They only update the @`PrevGovActionIds`@
-- directly and return the sequence of enacted action-ids and the set
-- of expired action-ids that inform us of the changes pending on
-- @`Proposals`@.
--
--   2.1. We take this sequence of enacted action-ids and set of expired
--   action-ids and apply them to the @`Proposals`@ in the ledger
--   state that now includes all the newly collected proposals and
--   votes from epoch n and epoch (n - 1), as this is a superset of
--   the pulsed set of proposals and votes. We do not expect this
--   operation to fail, since all invariants are expected to hold and
--   only an implementation bug could cause this operation to fail.
--   After applying this operation we expect the @`Proposals`@ to be in
--   a state, where (i) all expired actions and their descendants have
--   been pruned, and (ii) the sequence of enacted action-ids have been
--   promoted to be the root of the respective tree and their competing
--   or sibling action-ids and their descendants have been pruned from
--   the @`Proposals`@ tree.
--
--   2.2. The resultant @`Proposals`@ forest has all the latest
--   proposals and votes collected and with enactments and expirations
--   applied to existing ones, so we take a new snapshot to perform
--   pulsing computations on and start the new pulser (@`DRepPulser`@),
--   before entering the new epoch to collect more proposals and votes
--   in @`Proposals`@. Here we trust that the pulser accounts correctly
--   for newly collected votes on proposals from previous epochs that
--   haven't been ratified yet.
--
-- 3. Epoch (n + 1): New proposals and votes are collected from incoming
-- transactions into @`Proposals`@.
--
-- 4. Epoch (n + 1) boundary: The @`DRepPulser`@ now contains all
-- unratified proposals and votes from epoch n. Its calculation
-- is completed, ratified and enacted or expired. This updates
-- @`PrevGovActionIds`@ and gives us a new sequence of enacted
-- action-ids and set of expired actions-ids to apply to the
-- @`Proposals`@, which have been collecting even newer proposals and
-- votes to be a superset of our set of pulsed proposals and votes. And
-- so on...
module Cardano.Ledger.Conway.Governance.Proposals (
  -- * Intended interface to be used for all implementation
  Proposals,
  mapProposals,
  proposalsIds,
  proposalsActions,
  proposalsSize,
  proposalsAddAction,
  proposalsApplyEnactment,
  proposalsAddVote,
  proposalsLookupId,
  proposalsActionsMap,
  proposalsWithPurpose,
  toPrevGovActionIds,
  fromPrevGovActionIds,

  -- * To be used only for testing
  proposalsRemoveWithDescendants,
  TreeMaybe (..),
  toGovRelationTree,
  toGovRelationTreeEither,
  pPropsL,
  pRootsL,
  pGraphL,
  mkProposals,
  unsafeMkProposals,
  PRoot (..),
  prRootL,
  prChildrenL,
  PEdges (..),
  peChildrenL,
  PGraph (..),
  pGraphNodesL,
  proposalsDeposits,
) where

import Cardano.Ledger.Address (rewardAccountCredentialL)
import Cardano.Ledger.BaseTypes (
  StrictMaybe (..),
  isSJust,
  isSNothing,
  strictMaybe,
 )
import Cardano.Ledger.Binary (
  DecCBOR (..),
  DecShareCBOR (..),
  EncCBOR (..),
 )
import Cardano.Ledger.Coin (Coin, CompactForm (CompactCoin))
import Cardano.Ledger.Conway.Governance.Procedures
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Keys (KeyRole (Staking))
import Cardano.Ledger.UMap (addCompact, toCompact)
import Control.DeepSeq (NFData)
import Control.Exception (assert)
import Control.Monad (unless)
import Data.Aeson (ToJSON (..))
import Data.Default.Class (Default (..))
import Data.Either (partitionEithers)
import Data.Foldable as F (foldl', foldrM, toList)
import qualified Data.Map as Map
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import qualified Data.OMap.Strict as OMap
import qualified Data.OSet.Strict as OSet
import Data.Pulse (foldlM')
import Data.Sequence (Seq)
import Data.Sequence.Strict (StrictSeq (..))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Tree
import GHC.Generics (Generic)
import GHC.Stack
import Lens.Micro
import NoThunks.Class (NoThunks)

-- | The root of a single `Proposals` tree. `prRoot` is always expected
-- to be equal to the respective `PrevGovActionId` at the end of every
-- epoch boundary
data PRoot a = PRoot
  { forall a. PRoot a -> StrictMaybe a
prRoot :: !(StrictMaybe a)
  , forall a. PRoot a -> Set a
prChildren :: !(Set a)
  }
  deriving stock (Int -> PRoot a -> ShowS
forall a. Show a => Int -> PRoot a -> ShowS
forall a. Show a => [PRoot a] -> ShowS
forall a. Show a => PRoot a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PRoot a] -> ShowS
$cshowList :: forall a. Show a => [PRoot a] -> ShowS
show :: PRoot a -> String
$cshow :: forall a. Show a => PRoot a -> String
showsPrec :: Int -> PRoot a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PRoot a -> ShowS
Show, PRoot a -> PRoot a -> Bool
forall a. Eq a => PRoot a -> PRoot a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PRoot a -> PRoot a -> Bool
$c/= :: forall a. Eq a => PRoot a -> PRoot a -> Bool
== :: PRoot a -> PRoot a -> Bool
$c== :: forall a. Eq a => PRoot a -> PRoot a -> Bool
Eq, PRoot a -> PRoot a -> Bool
PRoot a -> PRoot a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (PRoot a)
forall a. Ord a => PRoot a -> PRoot a -> Bool
forall a. Ord a => PRoot a -> PRoot a -> Ordering
forall a. Ord a => PRoot a -> PRoot a -> PRoot a
min :: PRoot a -> PRoot a -> PRoot a
$cmin :: forall a. Ord a => PRoot a -> PRoot a -> PRoot a
max :: PRoot a -> PRoot a -> PRoot a
$cmax :: forall a. Ord a => PRoot a -> PRoot a -> PRoot a
>= :: PRoot a -> PRoot a -> Bool
$c>= :: forall a. Ord a => PRoot a -> PRoot a -> Bool
> :: PRoot a -> PRoot a -> Bool
$c> :: forall a. Ord a => PRoot a -> PRoot a -> Bool
<= :: PRoot a -> PRoot a -> Bool
$c<= :: forall a. Ord a => PRoot a -> PRoot a -> Bool
< :: PRoot a -> PRoot a -> Bool
$c< :: forall a. Ord a => PRoot a -> PRoot a -> Bool
compare :: PRoot a -> PRoot a -> Ordering
$ccompare :: forall a. Ord a => PRoot a -> PRoot a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PRoot a) x -> PRoot a
forall a x. PRoot a -> Rep (PRoot a) x
$cto :: forall a x. Rep (PRoot a) x -> PRoot a
$cfrom :: forall a x. PRoot a -> Rep (PRoot a) x
Generic)
  deriving anyclass (forall a. NoThunks a => Context -> PRoot a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Proxy (PRoot a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (PRoot a) -> String
$cshowTypeOf :: forall a. NoThunks a => Proxy (PRoot a) -> String
wNoThunks :: Context -> PRoot a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. NoThunks a => Context -> PRoot a -> IO (Maybe ThunkInfo)
noThunks :: Context -> PRoot a -> IO (Maybe ThunkInfo)
$cnoThunks :: forall a. NoThunks a => Context -> PRoot a -> IO (Maybe ThunkInfo)
NoThunks, forall a. NFData a => PRoot a -> ()
forall a. (a -> ()) -> NFData a
rnf :: PRoot a -> ()
$crnf :: forall a. NFData a => PRoot a -> ()
NFData, forall a. PRoot a
forall a. a -> Default a
def :: PRoot a
$cdef :: forall a. PRoot a
Default)

-- | A non-root edges in a `Proposals` tree. `peParent` is expected to be
-- a `SNothing` only at the begining when no governance actions has been
-- enacted yet.
data PEdges a = PEdges
  { forall a. PEdges a -> StrictMaybe a
peParent :: !(StrictMaybe a)
  , forall a. PEdges a -> Set a
peChildren :: !(Set a)
  }
  deriving stock (Int -> PEdges a -> ShowS
forall a. Show a => Int -> PEdges a -> ShowS
forall a. Show a => [PEdges a] -> ShowS
forall a. Show a => PEdges a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PEdges a] -> ShowS
$cshowList :: forall a. Show a => [PEdges a] -> ShowS
show :: PEdges a -> String
$cshow :: forall a. Show a => PEdges a -> String
showsPrec :: Int -> PEdges a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PEdges a -> ShowS
Show, PEdges a -> PEdges a -> Bool
forall a. Eq a => PEdges a -> PEdges a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PEdges a -> PEdges a -> Bool
$c/= :: forall a. Eq a => PEdges a -> PEdges a -> Bool
== :: PEdges a -> PEdges a -> Bool
$c== :: forall a. Eq a => PEdges a -> PEdges a -> Bool
Eq, PEdges a -> PEdges a -> Bool
PEdges a -> PEdges a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (PEdges a)
forall a. Ord a => PEdges a -> PEdges a -> Bool
forall a. Ord a => PEdges a -> PEdges a -> Ordering
forall a. Ord a => PEdges a -> PEdges a -> PEdges a
min :: PEdges a -> PEdges a -> PEdges a
$cmin :: forall a. Ord a => PEdges a -> PEdges a -> PEdges a
max :: PEdges a -> PEdges a -> PEdges a
$cmax :: forall a. Ord a => PEdges a -> PEdges a -> PEdges a
>= :: PEdges a -> PEdges a -> Bool
$c>= :: forall a. Ord a => PEdges a -> PEdges a -> Bool
> :: PEdges a -> PEdges a -> Bool
$c> :: forall a. Ord a => PEdges a -> PEdges a -> Bool
<= :: PEdges a -> PEdges a -> Bool
$c<= :: forall a. Ord a => PEdges a -> PEdges a -> Bool
< :: PEdges a -> PEdges a -> Bool
$c< :: forall a. Ord a => PEdges a -> PEdges a -> Bool
compare :: PEdges a -> PEdges a -> Ordering
$ccompare :: forall a. Ord a => PEdges a -> PEdges a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PEdges a) x -> PEdges a
forall a x. PEdges a -> Rep (PEdges a) x
$cto :: forall a x. Rep (PEdges a) x -> PEdges a
$cfrom :: forall a x. PEdges a -> Rep (PEdges a) x
Generic)
  deriving anyclass (forall a. NoThunks a => Context -> PEdges a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Proxy (PEdges a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (PEdges a) -> String
$cshowTypeOf :: forall a. NoThunks a => Proxy (PEdges a) -> String
wNoThunks :: Context -> PEdges a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. NoThunks a => Context -> PEdges a -> IO (Maybe ThunkInfo)
noThunks :: Context -> PEdges a -> IO (Maybe ThunkInfo)
$cnoThunks :: forall a. NoThunks a => Context -> PEdges a -> IO (Maybe ThunkInfo)
NoThunks, forall a. NFData a => PEdges a -> ()
forall a. (a -> ()) -> NFData a
rnf :: PEdges a -> ()
$crnf :: forall a. NFData a => PEdges a -> ()
NFData, forall a. PEdges a
forall a. a -> Default a
def :: PEdges a
$cdef :: forall a. PEdges a
Default)

-- | A single proposal-tree. This map represents all the action-ids that
-- form a tree.
newtype PGraph a = PGraph
  { forall a. PGraph a -> Map a (PEdges a)
unPGraph :: Map a (PEdges a)
  }
  deriving stock (Int -> PGraph a -> ShowS
forall a. Show a => Int -> PGraph a -> ShowS
forall a. Show a => [PGraph a] -> ShowS
forall a. Show a => PGraph a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PGraph a] -> ShowS
$cshowList :: forall a. Show a => [PGraph a] -> ShowS
show :: PGraph a -> String
$cshow :: forall a. Show a => PGraph a -> String
showsPrec :: Int -> PGraph a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> PGraph a -> ShowS
Show, PGraph a -> PGraph a -> Bool
forall a. Eq a => PGraph a -> PGraph a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGraph a -> PGraph a -> Bool
$c/= :: forall a. Eq a => PGraph a -> PGraph a -> Bool
== :: PGraph a -> PGraph a -> Bool
$c== :: forall a. Eq a => PGraph a -> PGraph a -> Bool
Eq, PGraph a -> PGraph a -> Bool
PGraph a -> PGraph a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (PGraph a)
forall a. Ord a => PGraph a -> PGraph a -> Bool
forall a. Ord a => PGraph a -> PGraph a -> Ordering
forall a. Ord a => PGraph a -> PGraph a -> PGraph a
min :: PGraph a -> PGraph a -> PGraph a
$cmin :: forall a. Ord a => PGraph a -> PGraph a -> PGraph a
max :: PGraph a -> PGraph a -> PGraph a
$cmax :: forall a. Ord a => PGraph a -> PGraph a -> PGraph a
>= :: PGraph a -> PGraph a -> Bool
$c>= :: forall a. Ord a => PGraph a -> PGraph a -> Bool
> :: PGraph a -> PGraph a -> Bool
$c> :: forall a. Ord a => PGraph a -> PGraph a -> Bool
<= :: PGraph a -> PGraph a -> Bool
$c<= :: forall a. Ord a => PGraph a -> PGraph a -> Bool
< :: PGraph a -> PGraph a -> Bool
$c< :: forall a. Ord a => PGraph a -> PGraph a -> Bool
compare :: PGraph a -> PGraph a -> Ordering
$ccompare :: forall a. Ord a => PGraph a -> PGraph a -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PGraph a) x -> PGraph a
forall a x. PGraph a -> Rep (PGraph a) x
$cto :: forall a x. Rep (PGraph a) x -> PGraph a
$cfrom :: forall a x. PGraph a -> Rep (PGraph a) x
Generic)
  deriving newtype (Context -> PGraph a -> IO (Maybe ThunkInfo)
Proxy (PGraph a) -> String
forall a. NoThunks a => Context -> PGraph a -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Proxy (PGraph a) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (PGraph a) -> String
$cshowTypeOf :: forall a. NoThunks a => Proxy (PGraph a) -> String
wNoThunks :: Context -> PGraph a -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall a. NoThunks a => Context -> PGraph a -> IO (Maybe ThunkInfo)
noThunks :: Context -> PGraph a -> IO (Maybe ThunkInfo)
$cnoThunks :: forall a. NoThunks a => Context -> PGraph a -> IO (Maybe ThunkInfo)
NoThunks, PGraph a -> ()
forall a. NFData a => PGraph a -> ()
forall a. (a -> ()) -> NFData a
rnf :: PGraph a -> ()
$crnf :: forall a. NFData a => PGraph a -> ()
NFData, PGraph a
forall a. PGraph a
forall a. a -> Default a
def :: PGraph a
$cdef :: forall a. PGraph a
Default)

prRootL :: Lens' (PRoot a) (StrictMaybe a)
prRootL :: forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a. PRoot a -> StrictMaybe a
prRoot forall a b. (a -> b) -> a -> b
$ \PRoot a
x StrictMaybe a
y -> PRoot a
x {prRoot :: StrictMaybe a
prRoot = StrictMaybe a
y}

prChildrenL :: Lens' (PRoot a) (Set a)
prChildrenL :: forall a. Lens' (PRoot a) (Set a)
prChildrenL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a. PRoot a -> Set a
prChildren forall a b. (a -> b) -> a -> b
$ \PRoot a
x Set a
y -> PRoot a
x {prChildren :: Set a
prChildren = Set a
y}

peChildrenL :: Lens' (PEdges a) (Set a)
peChildrenL :: forall a. Lens' (PEdges a) (Set a)
peChildrenL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a. PEdges a -> Set a
peChildren forall a b. (a -> b) -> a -> b
$ \PEdges a
x Set a
y -> PEdges a
x {peChildren :: Set a
peChildren = Set a
y}

pGraphNodesL :: Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL :: forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall a. PGraph a -> Map a (PEdges a)
unPGraph forall a b. (a -> b) -> a -> b
$ \PGraph a
x Map a (PEdges a)
y -> PGraph a
x {unPGraph :: Map a (PEdges a)
unPGraph = Map a (PEdges a)
y}

-- | Self-contained representation of all 4 proposals trees. This forest
-- is made up of only action-ids for nodes - full `GovActionState`s are
-- stored only once in the `OMap`. All functions in this module prefixed
-- with the string @proposals-@ operate on this data-type keeping it
-- consistent.
--
-- NOTE: The correct way to think about this data-structure is similar
-- to 4 of the following, one for each @`GovActionPurpose`@
--
-- @
--   data Tree a = Node (StrictMaybe a) [Tree a]
-- @
--
-- but because this does not allow us to look-up a node's edges in
-- predictable time, we use a map from nodes to their edges (parent and
-- children) to capture the graph (@`PGraph`@). We also need to always
-- know the roots of the 4 trees, and those we store in the @`PRoot`@
--
-- NOTE: At the end of an epoch boundary, we expect @`pRoots`@ to be the same
-- as the @`PrevGovActionIds`@ from the @`EnactState`@
data Proposals era = Proposals
  { forall era.
Proposals era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps :: !(OMap.OMap (GovActionId (EraCrypto era)) (GovActionState era))
  , forall era. Proposals era -> GovRelation PRoot era
pRoots :: !(GovRelation PRoot era)
  , forall era. Proposals era -> GovRelation PGraph era
pGraph :: !(GovRelation PGraph era)
  }
  deriving stock (Int -> Proposals era -> ShowS
forall era. EraPParams era => Int -> Proposals era -> ShowS
forall era. EraPParams era => [Proposals era] -> ShowS
forall era. EraPParams era => Proposals era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Proposals era] -> ShowS
$cshowList :: forall era. EraPParams era => [Proposals era] -> ShowS
show :: Proposals era -> String
$cshow :: forall era. EraPParams era => Proposals era -> String
showsPrec :: Int -> Proposals era -> ShowS
$cshowsPrec :: forall era. EraPParams era => Int -> Proposals era -> ShowS
Show, Proposals era -> Proposals era -> Bool
forall era.
EraPParams era =>
Proposals era -> Proposals era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Proposals era -> Proposals era -> Bool
$c/= :: forall era.
EraPParams era =>
Proposals era -> Proposals era -> Bool
== :: Proposals era -> Proposals era -> Bool
$c== :: forall era.
EraPParams era =>
Proposals era -> Proposals era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (Proposals era) x -> Proposals era
forall era x. Proposals era -> Rep (Proposals era) x
$cto :: forall era x. Rep (Proposals era) x -> Proposals era
$cfrom :: forall era x. Proposals era -> Rep (Proposals era) x
Generic)
  deriving anyclass (forall era.
EraPParams era =>
Context -> Proposals era -> IO (Maybe ThunkInfo)
forall era. EraPParams era => Proxy (Proposals era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Proposals era) -> String
$cshowTypeOf :: forall era. EraPParams era => Proxy (Proposals era) -> String
wNoThunks :: Context -> Proposals era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era.
EraPParams era =>
Context -> Proposals era -> IO (Maybe ThunkInfo)
noThunks :: Context -> Proposals era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era.
EraPParams era =>
Context -> Proposals era -> IO (Maybe ThunkInfo)
NoThunks, forall era. EraPParams era => Proposals era -> ()
forall a. (a -> ()) -> NFData a
rnf :: Proposals era -> ()
$crnf :: forall era. EraPParams era => Proposals era -> ()
NFData, forall era. Proposals era
forall a. a -> Default a
def :: Proposals era
$cdef :: forall era. Proposals era
Default)

-- | Make sure not to change the `gasId`, otherwise all hell will break loose.
mapProposals :: (GovActionState era -> GovActionState era) -> Proposals era -> Proposals era
mapProposals :: forall era.
(GovActionState era -> GovActionState era)
-> Proposals era -> Proposals era
mapProposals GovActionState era -> GovActionState era
f Proposals era
props = Proposals era
props {pProps :: OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps = forall v1 v2 k. (v1 -> v2) -> OMap k v1 -> OMap k v2
OMap.mapUnsafe GovActionState era -> GovActionState era
f (forall era.
Proposals era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps Proposals era
props)}

pPropsL :: Lens' (Proposals era) (OMap.OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL :: forall era.
Lens'
  (Proposals era)
  (OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era.
Proposals era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps forall a b. (a -> b) -> a -> b
$ \Proposals era
x OMap (GovActionId (EraCrypto era)) (GovActionState era)
y -> Proposals era
x {pProps :: OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps = OMap (GovActionId (EraCrypto era)) (GovActionState era)
y}

pRootsL :: Lens' (Proposals era) (GovRelation PRoot era)
pRootsL :: forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. Proposals era -> GovRelation PRoot era
pRoots forall a b. (a -> b) -> a -> b
$ \Proposals era
x GovRelation PRoot era
y -> Proposals era
x {pRoots :: GovRelation PRoot era
pRoots = GovRelation PRoot era
y}

pGraphL :: Lens' (Proposals era) (GovRelation PGraph era)
pGraphL :: forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall era. Proposals era -> GovRelation PGraph era
pGraph forall a b. (a -> b) -> a -> b
$ \Proposals era
x GovRelation PGraph era
y -> Proposals era
x {pGraph :: GovRelation PGraph era
pGraph = GovRelation PGraph era
y}

instance EraPParams era => ToJSON (Proposals era) where
  toJSON :: Proposals era -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Proposals era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps
  toEncoding :: Proposals era -> Encoding
toEncoding = forall a. ToJSON a => a -> Encoding
toEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Proposals era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps

proposalsWithPurpose ::
  forall p era.
  ToGovActionPurpose p =>
  (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) ->
  Proposals era ->
  Map (GovPurposeId p era) (GovActionState era)
proposalsWithPurpose :: forall (p :: GovActionPurpose) era.
ToGovActionPurpose p =>
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> Proposals era -> Map (GovPurposeId p era) (GovActionState era)
proposalsWithPurpose forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
propL Proposals {OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps :: OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps :: forall era.
Proposals era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps, GovRelation PGraph era
pGraph :: GovRelation PGraph era
pGraph :: forall era. Proposals era -> GovRelation PGraph era
pGraph} =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False Map (GovPurposeId p era) (GovActionState era)
fallBackMapWithPurpose) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey
      (\(GovPurposeId GovActionId (EraCrypto era)
govActionId) PEdges (GovPurposeId p era)
_ -> forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup GovActionId (EraCrypto era)
govActionId OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps)
      (forall a. PGraph a -> Map a (PEdges a)
unPGraph (GovRelation PGraph era
pGraph forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
propL))
  where
    -- In case there is a bug and there is an inconsistency in state we want to report in
    -- testing, while falling back onto alternative slower implementation
    fallBackMapWithPurpose :: Map (GovPurposeId p era) (GovActionState era)
    fallBackMapWithPurpose :: Map (GovPurposeId p era) (GovActionState era)
fallBackMapWithPurpose =
      forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId forall a b. (a -> b) -> a -> b
$
        forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (forall (p :: GovActionPurpose) era.
ToGovActionPurpose p =>
GovAction era -> Bool
isGovActionWithPurpose @p forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ProposalProcedure era -> GovAction era
pProcGovAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. GovActionState era -> ProposalProcedure era
gasProposalProcedure) (forall k v. OMap k v -> Map k v
OMap.toMap OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps)

-- | Add a single @`GovActionState`@ to the @`Proposals`@ forest.
-- The tree to which it is added is picked according to its
-- @`GovActionPurpose`@. Returns `Nothing` when the operation cannot
-- succeed.
proposalsAddAction ::
  forall era.
  (EraPParams era, HasCallStack) =>
  GovActionState era ->
  Proposals era ->
  Maybe (Proposals era)
proposalsAddAction :: forall era.
(EraPParams era, ?callStack::CallStack) =>
GovActionState era -> Proposals era -> Maybe (Proposals era)
proposalsAddAction GovActionState era
gas Proposals era
ps = forall era.
(EraPParams era, ?callStack::CallStack) =>
GovActionState era
-> Proposals era -> Proposals era -> Proposals era
checkInvariantAfterAddition GovActionState era
gas Proposals era
ps forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
GovActionState era -> Proposals era -> Maybe (Proposals era)
runProposalsAddAction GovActionState era
gas Proposals era
ps

runProposalsAddAction ::
  forall era.
  GovActionState era ->
  Proposals era ->
  Maybe (Proposals era)
runProposalsAddAction :: forall era.
GovActionState era -> Proposals era -> Maybe (Proposals era)
runProposalsAddAction GovActionState era
gas Proposals era
ps = forall era a.
GovActionState era
-> a
-> (forall (p :: GovActionPurpose).
    (forall (f :: * -> *).
     Lens' (GovRelation f era) (f (GovPurposeId p era)))
    -> StrictMaybe (GovPurposeId p era) -> GovPurposeId p era -> a)
-> a
withGovActionParent GovActionState era
gas (forall a. a -> Maybe a
Just Proposals era
psWithGas) forall (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> StrictMaybe (GovPurposeId p era)
-> GovPurposeId p era
-> Maybe (Proposals era)
update
  where
    psWithGas :: Proposals era
psWithGas = Proposals era
ps forall a b. a -> (a -> b) -> b
& forall era.
Lens'
  (Proposals era)
  (OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall k v. HasOKey k v => OMap k v -> v -> OMap k v
OMap.||> GovActionState era
gas)
    -- Append a new GovActionState to the Proposals and then add it to the set of children
    -- for its parent as well as initiate an empty lineage for this new child.
    update ::
      (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) ->
      StrictMaybe (GovPurposeId p era) ->
      GovPurposeId p era ->
      Maybe (Proposals era)
    update :: forall (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> StrictMaybe (GovPurposeId p era)
-> GovPurposeId p era
-> Maybe (Proposals era)
update forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL StrictMaybe (GovPurposeId p era)
parent GovPurposeId p era
newId
      | StrictMaybe (GovPurposeId p era)
parent forall a. Eq a => a -> a -> Bool
== Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL =
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Proposals era
psWithGas
              forall a b. a -> (a -> b) -> b
& forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (Set a)
prChildrenL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert GovPurposeId p era
newId
              forall a b. a -> (a -> b) -> b
& forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert GovPurposeId p era
newId (forall a. StrictMaybe a -> Set a -> PEdges a
PEdges StrictMaybe (GovPurposeId p era)
parent forall a. Set a
Set.empty)
      | SJust GovPurposeId p era
parentId <- StrictMaybe (GovPurposeId p era)
parent
      , forall k a. Ord k => k -> Map k a -> Bool
Map.member GovPurposeId p era
parentId forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL =
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            Proposals era
psWithGas
              forall a b. a -> (a -> b) -> b
& forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
                forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ( forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert GovPurposeId p era
newId (forall a. StrictMaybe a -> Set a -> PEdges a
PEdges (forall a. a -> StrictMaybe a
SJust GovPurposeId p era
parentId) forall a. Set a
Set.empty)
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall a. Lens' (PEdges a) (Set a)
peChildrenL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert GovPurposeId p era
newId) GovPurposeId p era
parentId
                   )
      | Bool
otherwise = forall a. Maybe a
Nothing

-- | Reconstruct the @`Proposals`@ forest from an @`OMap`@ of
-- @`GovActionState`@s and the 4 roots (@`PrevGovActionIds`@)
mkProposals ::
  (EraPParams era, MonadFail m) =>
  GovRelation StrictMaybe era ->
  OMap.OMap (GovActionId (EraCrypto era)) (GovActionState era) ->
  m (Proposals era)
mkProposals :: forall era (m :: * -> *).
(EraPParams era, MonadFail m) =>
GovRelation StrictMaybe era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
-> m (Proposals era)
mkProposals GovRelation StrictMaybe era
pgais OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap = do
  ps :: Proposals era
ps@(Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap' GovRelation PRoot era
_roots GovRelation PGraph era
_hierarchy) <-
    forall (t :: * -> *) (m :: * -> *) ans k.
(Foldable t, Monad m) =>
(ans -> k -> m ans) -> ans -> t k -> m ans
foldlM'
      ( \Proposals era
props GovActionState era
gas ->
          case forall era.
(EraPParams era, ?callStack::CallStack) =>
GovActionState era -> Proposals era -> Maybe (Proposals era)
proposalsAddAction GovActionState era
gas Proposals era
props of
            Maybe (Proposals era)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"mkProposals: Could not add a proposal" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (GovActionState era
gas forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (GovActionState era) (GovActionId (EraCrypto era))
gasIdL)
            Just Proposals era
props' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Proposals era
props'
      )
      Proposals era
initialProposals
      OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap forall a. Eq a => a -> a -> Bool
== OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap') forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mkProposals: OMap is malformed"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Proposals era
ps
  where
    initialProposals :: Proposals era
initialProposals = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. GovRelation StrictMaybe era -> GovRelation PRoot era
fromPrevGovActionIds GovRelation StrictMaybe era
pgais

-- | Reconstruct the @`Proposals`@ forest from an @`OMap`@ of
-- @`GovActionState`@s and the 4 roots (@`PrevGovActionIds`@).
-- This function can fail and may return a malformed `Proposals`
-- if not given correct inputs.
--
-- WARNING: Should only be used for testing!
unsafeMkProposals ::
  HasCallStack =>
  GovRelation StrictMaybe era ->
  OMap.OMap (GovActionId (EraCrypto era)) (GovActionState era) ->
  Proposals era
unsafeMkProposals :: forall era.
(?callStack::CallStack) =>
GovRelation StrictMaybe era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
-> Proposals era
unsafeMkProposals GovRelation StrictMaybe era
pgais OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {era}. Proposals era -> GovActionState era -> Proposals era
unsafeProposalsAddAction Proposals era
initialProposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap
  where
    initialProposals :: Proposals era
initialProposals = forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. GovRelation StrictMaybe era -> GovRelation PRoot era
fromPrevGovActionIds GovRelation StrictMaybe era
pgais
    unsafeProposalsAddAction :: Proposals era -> GovActionState era -> Proposals era
unsafeProposalsAddAction Proposals era
ps GovActionState era
gas =
      case forall era.
GovActionState era -> Proposals era -> Maybe (Proposals era)
runProposalsAddAction GovActionState era
gas Proposals era
ps of
        Just Proposals era
p -> Proposals era
p
        Maybe (Proposals era)
Nothing -> forall a. (?callStack::CallStack) => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unsafeMkProposals: runProposalsAddAction failed for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (GovActionState era
gas forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (GovActionState era) (GovActionId (EraCrypto era))
gasIdL)

instance EraPParams era => EncCBOR (Proposals era) where
  encCBOR :: Proposals era -> Encoding
encCBOR Proposals era
ps =
    let roots :: GovRelation StrictMaybe era
roots = forall era. GovRelation PRoot era -> GovRelation StrictMaybe era
toPrevGovActionIds forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL
     in forall a. EncCBOR a => a -> Encoding
encCBOR (GovRelation StrictMaybe era
roots, Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (Proposals era)
  (OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL)

instance EraPParams era => DecCBOR (Proposals era) where
  decCBOR :: forall s. Decoder s (Proposals era)
decCBOR = forall a s. DecCBOR a => Decoder s a
decCBOR forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall era (m :: * -> *).
(EraPParams era, MonadFail m) =>
GovRelation StrictMaybe era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
-> m (Proposals era)
mkProposals

-- TODO: Implement Sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486
instance EraPParams era => DecShareCBOR (Proposals era) where
  decShareCBOR :: forall s. Share (Proposals era) -> Decoder s (Proposals era)
decShareCBOR Share (Proposals era)
_ = forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Add a vote to an existing `GovActionState`. This is a no-op if the
-- provided `GovActionId` does not already exist
proposalsAddVote ::
  Voter (EraCrypto era) ->
  Vote ->
  GovActionId (EraCrypto era) ->
  Proposals era ->
  Proposals era
proposalsAddVote :: forall era.
Voter (EraCrypto era)
-> Vote
-> GovActionId (EraCrypto era)
-> Proposals era
-> Proposals era
proposalsAddVote Voter (EraCrypto era)
voter Vote
vote GovActionId (EraCrypto era)
gai (Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap GovRelation PRoot era
roots GovRelation PGraph era
hierarchy) =
  forall era.
OMap (GovActionId (EraCrypto era)) (GovActionState era)
-> GovRelation PRoot era -> GovRelation PGraph era -> Proposals era
Proposals (forall k v. HasOKey k v => (v -> v) -> k -> OMap k v -> OMap k v
OMap.adjust GovActionState era -> GovActionState era
updateVote GovActionId (EraCrypto era)
gai OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap) GovRelation PRoot era
roots GovRelation PGraph era
hierarchy
  where
    insertVote ::
      Ord k =>
      Lens' (GovActionState era) (Map k Vote) ->
      k ->
      GovActionState era ->
      GovActionState era
    insertVote :: forall k era.
Ord k =>
Lens' (GovActionState era) (Map k Vote)
-> k -> GovActionState era -> GovActionState era
insertVote Lens' (GovActionState era) (Map k Vote)
l k
k = Lens' (GovActionState era) (Map k Vote)
l forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k Vote
vote
    updateVote :: GovActionState era -> GovActionState era
updateVote = case Voter (EraCrypto era)
voter of
      DRepVoter Credential 'DRepRole (EraCrypto era)
c -> forall k era.
Ord k =>
Lens' (GovActionState era) (Map k Vote)
-> k -> GovActionState era -> GovActionState era
insertVote forall era.
Lens'
  (GovActionState era)
  (Map (Credential 'DRepRole (EraCrypto era)) Vote)
gasDRepVotesL Credential 'DRepRole (EraCrypto era)
c
      StakePoolVoter KeyHash 'StakePool (EraCrypto era)
kh -> forall k era.
Ord k =>
Lens' (GovActionState era) (Map k Vote)
-> k -> GovActionState era -> GovActionState era
insertVote forall era.
Lens'
  (GovActionState era)
  (Map (KeyHash 'StakePool (EraCrypto era)) Vote)
gasStakePoolVotesL KeyHash 'StakePool (EraCrypto era)
kh
      CommitteeVoter Credential 'HotCommitteeRole (EraCrypto era)
c -> forall k era.
Ord k =>
Lens' (GovActionState era) (Map k Vote)
-> k -> GovActionState era -> GovActionState era
insertVote forall era.
Lens'
  (GovActionState era)
  (Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote)
gasCommitteeVotesL Credential 'HotCommitteeRole (EraCrypto era)
c

-- | For each action-id in the given set. attempt to remove it from
-- the @`Proposals`@ forest based on its purpose. Although the removal
-- operations are applied to parts of the forest without any checks, we
-- cover them in property-tests
proposalsRemoveIds ::
  forall era.
  EraPParams era =>
  Set (GovActionId (EraCrypto era)) ->
  Proposals era ->
  (Proposals era, Map.Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveIds :: forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveIds Set (GovActionId (EraCrypto era))
gais Proposals era
ps =
  let (OMap (GovActionId (EraCrypto era)) (GovActionState era)
retainedOMap, Map (GovActionId (EraCrypto era)) (GovActionState era)
removedFromOMap) = forall k v. Ord k => Set k -> OMap k v -> (OMap k v, Map k v)
OMap.extractKeys Set (GovActionId (EraCrypto era))
gais forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (Proposals era)
  (OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL
      (GovRelation PRoot era
roots, GovRelation PGraph era
hierarchy) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' forall {era}.
(GovRelation PRoot era, GovRelation PGraph era)
-> GovActionState era
-> (GovRelation PRoot era, GovRelation PGraph era)
removeEach (Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL, Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL) Map (GovActionId (EraCrypto era)) (GovActionState era)
removedFromOMap
   in (forall era.
(EraPParams era, ?callStack::CallStack) =>
Set (GovActionId (EraCrypto era))
-> Proposals era -> Proposals era -> Proposals era
checkInvariantAfterDeletion Set (GovActionId (EraCrypto era))
gais Proposals era
ps forall a b. (a -> b) -> a -> b
$ forall era.
OMap (GovActionId (EraCrypto era)) (GovActionState era)
-> GovRelation PRoot era -> GovRelation PGraph era -> Proposals era
Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
retainedOMap GovRelation PRoot era
roots GovRelation PGraph era
hierarchy, Map (GovActionId (EraCrypto era)) (GovActionState era)
removedFromOMap)
  where
    removeEach :: (GovRelation PRoot era, GovRelation PGraph era)
-> GovActionState era
-> (GovRelation PRoot era, GovRelation PGraph era)
removeEach accum :: (GovRelation PRoot era, GovRelation PGraph era)
accum@(!GovRelation PRoot era
roots, !GovRelation PGraph era
graph) GovActionState era
gas =
      forall era a.
GovActionState era
-> a
-> (forall (p :: GovActionPurpose).
    (forall (f :: * -> *).
     Lens' (GovRelation f era) (f (GovPurposeId p era)))
    -> StrictMaybe (GovPurposeId p era) -> GovPurposeId p era -> a)
-> a
withGovActionParent GovActionState era
gas (GovRelation PRoot era, GovRelation PGraph era)
accum forall a b. (a -> b) -> a -> b
$ \forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL StrictMaybe (GovPurposeId p era)
parent GovPurposeId p era
gpi ->
        if StrictMaybe (GovPurposeId p era)
parent forall a. Eq a => a -> a -> Bool
== GovRelation PRoot era
roots forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL
          then
            ( GovRelation PRoot era
roots forall a b. a -> (a -> b) -> b
& forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (Set a)
prChildrenL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.delete GovPurposeId p era
gpi
            , GovRelation PGraph era
graph forall a b. a -> (a -> b) -> b
& forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete GovPurposeId p era
gpi
            )
          else
            ( GovRelation PRoot era
roots
            , GovRelation PGraph era
graph
                forall a b. a -> (a -> b) -> b
& forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete GovPurposeId p era
gpi
                forall a b. a -> (a -> b) -> b
& case StrictMaybe (GovPurposeId p era)
parent of
                  StrictMaybe (GovPurposeId p era)
SNothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a. a -> a
id
                  SJust GovPurposeId p era
parentGpi ->
                    forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (forall a. Lens' (PEdges a) (Set a)
peChildrenL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.delete GovPurposeId p era
gpi) GovPurposeId p era
parentGpi
            )

-- | Remove the set of given action-ids with their descendants from the
-- @`Proposals`@ forest. Cannot be used for removing enacted GovActionIds (i.e. roots)
proposalsRemoveWithDescendants ::
  EraPParams era =>
  Set (GovActionId (EraCrypto era)) ->
  Proposals era ->
  (Proposals era, Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants :: forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants Set (GovActionId (EraCrypto era))
gais ps :: Proposals era
ps@(Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap GovRelation PRoot era
_roots GovRelation PGraph era
graph) =
  forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveIds (Set (GovActionId (EraCrypto era))
gais forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap GovActionId (EraCrypto era) -> Set (GovActionId (EraCrypto era))
getAllDescendants Set (GovActionId (EraCrypto era))
gais) Proposals era
ps
  where
    -- Recursively get all of the descendants for those actions that have lineage
    getAllDescendants :: GovActionId (EraCrypto era) -> Set (GovActionId (EraCrypto era))
getAllDescendants GovActionId (EraCrypto era)
gai =
      case forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup GovActionId (EraCrypto era)
gai OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap of
        Maybe (GovActionState era)
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a. Monoid a => a
mempty
        Just GovActionState era
gas -> forall era a.
GovActionState era
-> a
-> (forall (p :: GovActionPurpose).
    (forall (f :: * -> *).
     Lens' (GovRelation f era) (f (GovPurposeId p era)))
    -> StrictMaybe (GovPurposeId p era) -> GovPurposeId p era -> a)
-> a
withGovActionParent GovActionState era
gas forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL StrictMaybe (GovPurposeId p era)
_ ->
          let go :: Set (GovActionId (EraCrypto era))
-> GovPurposeId p era -> Set (GovActionId (EraCrypto era))
go Set (GovActionId (EraCrypto era))
acc GovPurposeId p era
gpi =
                case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GovPurposeId p era
gpi forall a b. (a -> b) -> a -> b
$ GovRelation PGraph era
graph forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL of
                  Maybe (PEdges (GovPurposeId p era))
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False Set (GovActionId (EraCrypto era))
acc
                  Just (PEdges StrictMaybe (GovPurposeId p era)
_parent Set (GovPurposeId p era)
children) ->
                    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' Set (GovActionId (EraCrypto era))
-> GovPurposeId p era -> Set (GovActionId (EraCrypto era))
go (forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
unGovPurposeId Set (GovPurposeId p era)
children forall a. Semigroup a => a -> a -> a
<> Set (GovActionId (EraCrypto era))
acc) Set (GovPurposeId p era)
children
           in Set (GovActionId (EraCrypto era))
-> GovPurposeId p era -> Set (GovActionId (EraCrypto era))
go forall a. Monoid a => a
mempty

-- | For use in the @`EPOCH`@ rule. Apply the result of
-- @`extractDRepPulsingState`@ to the @`Proposals`@ forest, so that:
--   i. all the expired action-ids and their descendants are removed,
--   and
--   ii. the sequence of enacted action-ids is promoted to the root,
--   removing competing/sibling action-ids and their descendants at each
--   step
proposalsApplyEnactment ::
  forall era.
  EraPParams era =>
  Seq (GovActionState era) ->
  Set (GovActionId (EraCrypto era)) ->
  Proposals era ->
  ( Proposals era
  , Map (GovActionId (EraCrypto era)) (GovActionState era) -- Enacted actions
  , Map (GovActionId (EraCrypto era)) (GovActionState era) -- Removed due to enactment
  , Map (GovActionId (EraCrypto era)) (GovActionState era) -- Removed due to expiry
  )
proposalsApplyEnactment :: forall era.
EraPParams era =>
Seq (GovActionState era)
-> Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsApplyEnactment Seq (GovActionState era)
enactedGass Set (GovActionId (EraCrypto era))
expiredGais Proposals era
props =
  let (Proposals era
unexpiredProposals, Map (GovActionId (EraCrypto era)) (GovActionState era)
expiredRemoved) = forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants Set (GovActionId (EraCrypto era))
expiredGais Proposals era
props
      (Proposals era
enactedProposalsState, Map (GovActionId (EraCrypto era)) (GovActionState era)
enacted, Map (GovActionId (EraCrypto era)) (GovActionState era)
removedDueToEnactment) =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (Proposals era,
 Map (GovActionId (EraCrypto era)) (GovActionState era),
 Map (GovActionId (EraCrypto era)) (GovActionState era))
-> GovActionState era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
enact (Proposals era
unexpiredProposals, forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty) Seq (GovActionState era)
enactedGass
   in (Proposals era
enactedProposalsState, Map (GovActionId (EraCrypto era)) (GovActionState era)
enacted, Map (GovActionId (EraCrypto era)) (GovActionState era)
removedDueToEnactment, Map (GovActionId (EraCrypto era)) (GovActionState era)
expiredRemoved)
  where
    enact :: (Proposals era,
 Map (GovActionId (EraCrypto era)) (GovActionState era),
 Map (GovActionId (EraCrypto era)) (GovActionState era))
-> GovActionState era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
enact (!Proposals era
ps, !Map (GovActionId (EraCrypto era)) (GovActionState era)
enacted, !Map (GovActionId (EraCrypto era)) (GovActionState era)
removed) GovActionState era
gas = forall era a.
GovActionState era
-> a
-> (forall (p :: GovActionPurpose).
    (forall (f :: * -> *).
     Lens' (GovRelation f era) (f (GovPurposeId p era)))
    -> StrictMaybe (GovPurposeId p era) -> GovPurposeId p era -> a)
-> a
withGovActionParent GovActionState era
gas (Proposals era,
 Map (GovActionId (EraCrypto era)) (GovActionState era),
 Map (GovActionId (EraCrypto era)) (GovActionState era))
enactWithoutRoot forall (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> StrictMaybe (GovPurposeId p era)
-> GovPurposeId p era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
enactFromRoot
      where
        gai :: GovActionId (EraCrypto era)
gai = GovActionState era
gas forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (GovActionState era) (GovActionId (EraCrypto era))
gasIdL
        enactWithoutRoot ::
          ( Proposals era
          , Map (GovActionId (EraCrypto era)) (GovActionState era)
          , Map (GovActionId (EraCrypto era)) (GovActionState era)
          )
        enactWithoutRoot :: (Proposals era,
 Map (GovActionId (EraCrypto era)) (GovActionState era),
 Map (GovActionId (EraCrypto era)) (GovActionState era))
enactWithoutRoot =
          let (OMap (GovActionId (EraCrypto era)) (GovActionState era)
newOMap, Map (GovActionId (EraCrypto era)) (GovActionState era)
enactedAction) = forall k v. Ord k => Set k -> OMap k v -> (OMap k v, Map k v)
OMap.extractKeys (forall a. a -> Set a
Set.singleton GovActionId (EraCrypto era)
gai) forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (Proposals era)
  (OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL
           in forall a. (?callStack::CallStack) => Bool -> a -> a
assert -- we want an AssertionFailure here for exhaustive property-testing
                (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Bool
Map.null Map (GovActionId (EraCrypto era)) (GovActionState era)
enactedAction)
                ( Proposals era
ps forall a b. a -> (a -> b) -> b
& forall era.
Lens'
  (Proposals era)
  (OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ OMap (GovActionId (EraCrypto era)) (GovActionState era)
newOMap
                , Map (GovActionId (EraCrypto era)) (GovActionState era)
enacted forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map (GovActionId (EraCrypto era)) (GovActionState era)
enactedAction
                , Map (GovActionId (EraCrypto era)) (GovActionState era)
removed
                )
        enactFromRoot ::
          (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) ->
          StrictMaybe (GovPurposeId p era) ->
          GovPurposeId p era ->
          ( Proposals era
          , Map (GovActionId (EraCrypto era)) (GovActionState era)
          , Map (GovActionId (EraCrypto era)) (GovActionState era)
          )
        enactFromRoot :: forall (p :: GovActionPurpose).
(forall (f :: * -> *).
 Lens' (GovRelation f era) (f (GovPurposeId p era)))
-> StrictMaybe (GovPurposeId p era)
-> GovPurposeId p era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era),
    Map (GovActionId (EraCrypto era)) (GovActionState era))
enactFromRoot forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL StrictMaybe (GovPurposeId p era)
parent GovPurposeId p era
gpi =
          let siblings :: Set (GovActionId (EraCrypto era))
siblings =
                forall a. Ord a => a -> Set a -> Set a
Set.delete GovActionId (EraCrypto era)
gai forall a b. (a -> b) -> a -> b
$
                  forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
unGovPurposeId (Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (Set a)
prChildrenL)
              newRootChildren :: Set (GovPurposeId p era)
newRootChildren =
                case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GovPurposeId p era
gpi forall a b. (a -> b) -> a -> b
$ Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL of
                  Maybe (PEdges (GovPurposeId p era))
Nothing -> forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
False forall a. Set a
Set.empty
                  Just PEdges (GovPurposeId p era)
pe -> forall a. PEdges a -> Set a
peChildren PEdges (GovPurposeId p era)
pe
              (Proposals era
withoutSiblings, Map (GovActionId (EraCrypto era)) (GovActionState era)
removedActions) = forall era.
EraPParams era =>
Set (GovActionId (EraCrypto era))
-> Proposals era
-> (Proposals era,
    Map (GovActionId (EraCrypto era)) (GovActionState era))
proposalsRemoveWithDescendants Set (GovActionId (EraCrypto era))
siblings Proposals era
ps
              newGraph :: Map (GovPurposeId p era) (PEdges (GovPurposeId p era))
newGraph = forall k a. Ord k => k -> Map k a -> Map k a
Map.delete GovPurposeId p era
gpi forall a b. (a -> b) -> a -> b
$ Proposals era
withoutSiblings forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL
              (OMap (GovActionId (EraCrypto era)) (GovActionState era)
newOMap, Map (GovActionId (EraCrypto era)) (GovActionState era)
enactedAction) =
                forall k v. Ord k => Set k -> OMap k v -> (OMap k v, Map k v)
OMap.extractKeys (forall a. a -> Set a
Set.singleton GovActionId (EraCrypto era)
gai) forall a b. (a -> b) -> a -> b
$ Proposals era
withoutSiblings forall s a. s -> Getting a s a -> a
^. forall era.
Lens'
  (Proposals era)
  (OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL
              newProposals :: Proposals era
newProposals =
                Proposals era
withoutSiblings
                  forall a b. a -> (a -> b) -> b
& forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust GovPurposeId p era
gpi -- Set the new root
                  forall a b. a -> (a -> b) -> b
& forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (Set a)
prChildrenL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Set (GovPurposeId p era)
newRootChildren
                  forall a b. a -> (a -> b) -> b
& forall era. Lens' (Proposals era) (GovRelation PGraph era)
pGraphL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PGraph a) (Map a (PEdges a))
pGraphNodesL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (GovPurposeId p era) (PEdges (GovPurposeId p era))
newGraph
                  forall a b. a -> (a -> b) -> b
& forall era.
Lens'
  (Proposals era)
  (OMap (GovActionId (EraCrypto era)) (GovActionState era))
pPropsL forall s t a b. ASetter s t a b -> b -> s -> t
.~ OMap (GovActionId (EraCrypto era)) (GovActionState era)
newOMap
           in forall a. (?callStack::CallStack) => Bool -> a -> a
assert
                (Proposals era
ps forall s a. s -> Getting a s a -> a
^. forall era. Lens' (Proposals era) (GovRelation PRoot era)
pRootsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (PRoot a) (StrictMaybe a)
prRootL forall a. Eq a => a -> a -> Bool
== StrictMaybe (GovPurposeId p era)
parent)
                ( forall era.
(EraPParams era, ?callStack::CallStack) =>
Set (GovActionId (EraCrypto era))
-> Proposals era -> Proposals era -> Proposals era
checkInvariantAfterDeletion (forall a. a -> Set a
Set.singleton GovActionId (EraCrypto era)
gai) Proposals era
withoutSiblings Proposals era
newProposals
                , Map (GovActionId (EraCrypto era)) (GovActionState era)
enacted forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map (GovActionId (EraCrypto era)) (GovActionState era)
enactedAction
                , Map (GovActionId (EraCrypto era)) (GovActionState era)
removed forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map (GovActionId (EraCrypto era)) (GovActionState era)
removedActions
                )

-- | Get the sequence of `GovActionState`s
proposalsActions ::
  Proposals era ->
  StrictSeq (GovActionState era)
proposalsActions :: forall era. Proposals era -> StrictSeq (GovActionState era)
proposalsActions (Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap GovRelation PRoot era
_ GovRelation PGraph era
_) = forall k v. Ord k => OMap k v -> StrictSeq v
OMap.toStrictSeq OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap

-- | Get a mapping from the reward-account staking credentials to deposits of
-- all proposals.
proposalsDeposits ::
  Proposals era ->
  Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
proposalsDeposits :: forall era.
Proposals era
-> Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
proposalsDeposits =
  forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl'
    ( \Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
gasMap GovActionState era
gas ->
        forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith
          CompactForm Coin -> CompactForm Coin -> CompactForm Coin
addCompact
          (GovActionState era
gas forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (GovActionState era) (RewardAccount (EraCrypto era))
gasReturnAddrL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (RewardAccount c) (Credential 'Staking c)
rewardAccountCredentialL)
          (forall a. a -> Maybe a -> a
fromMaybe (Word64 -> CompactForm Coin
CompactCoin Word64
0) forall a b. (a -> b) -> a -> b
$ forall a. Compactible a => a -> Maybe (CompactForm a)
toCompact forall a b. (a -> b) -> a -> b
$ GovActionState era
gas forall s a. s -> Getting a s a -> a
^. forall era. Lens' (GovActionState era) Coin
gasDepositL)
          Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin)
gasMap
    )
    forall a. Monoid a => a
mempty
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Proposals era -> StrictSeq (GovActionState era)
proposalsActions

-- | Get the sequence of `GovActionId`s
proposalsIds ::
  Proposals era ->
  StrictSeq (GovActionId (EraCrypto era))
proposalsIds :: forall era.
Proposals era -> StrictSeq (GovActionId (EraCrypto era))
proposalsIds (Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap GovRelation PRoot era
_ GovRelation PGraph era
_) = forall k v. OMap k v -> StrictSeq k
OMap.toStrictSeqOKeys OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap

-- | Get the unordered map of `GovActionId`s and `GovActionState`s
proposalsActionsMap ::
  Proposals era ->
  Map (GovActionId (EraCrypto era)) (GovActionState era)
proposalsActionsMap :: forall era.
Proposals era
-> Map (GovActionId (EraCrypto era)) (GovActionState era)
proposalsActionsMap (Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap GovRelation PRoot era
_ GovRelation PGraph era
_) = forall k v. OMap k v -> Map k v
OMap.toMap OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap

proposalsSize :: Proposals era -> Int
proposalsSize :: forall era. Proposals era -> Int
proposalsSize (Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap GovRelation PRoot era
_ GovRelation PGraph era
_) = forall k v. OMap k v -> Int
OMap.size OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap

proposalsLookupId ::
  GovActionId (EraCrypto era) ->
  Proposals era ->
  Maybe (GovActionState era)
proposalsLookupId :: forall era.
GovActionId (EraCrypto era)
-> Proposals era -> Maybe (GovActionState era)
proposalsLookupId GovActionId (EraCrypto era)
gai (Proposals OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap GovRelation PRoot era
_ GovRelation PGraph era
_) = forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup GovActionId (EraCrypto era)
gai OMap (GovActionId (EraCrypto era)) (GovActionState era)
omap

toPrevGovActionIds :: GovRelation PRoot era -> GovRelation StrictMaybe era
toPrevGovActionIds :: forall era. GovRelation PRoot era -> GovRelation StrictMaybe era
toPrevGovActionIds = forall (f :: * -> *) (g :: * -> *) era.
(forall a. f a -> g a) -> GovRelation f era -> GovRelation g era
hoistGovRelation forall a. PRoot a -> StrictMaybe a
prRoot

fromPrevGovActionIds :: GovRelation StrictMaybe era -> GovRelation PRoot era
fromPrevGovActionIds :: forall era. GovRelation StrictMaybe era -> GovRelation PRoot era
fromPrevGovActionIds = forall (f :: * -> *) (g :: * -> *) era.
(forall a. f a -> g a) -> GovRelation f era -> GovRelation g era
hoistGovRelation (forall a. StrictMaybe a -> Set a -> PRoot a
`PRoot` forall a. Set a
Set.empty)

---------------------
-- Debugging tools --
---------------------

-- | Wraper type, which serves as a composition of @`Tree` . `StrictMaybe`@
--
-- Also its Show instance will print a nice tree structure.
data TreeMaybe a = TreeMaybe {forall a. TreeMaybe a -> Tree (StrictMaybe a)
unTreeMaybe :: Tree (StrictMaybe a)}
  deriving (TreeMaybe a -> TreeMaybe a -> Bool
forall a. Eq a => TreeMaybe a -> TreeMaybe a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreeMaybe a -> TreeMaybe a -> Bool
$c/= :: forall a. Eq a => TreeMaybe a -> TreeMaybe a -> Bool
== :: TreeMaybe a -> TreeMaybe a -> Bool
$c== :: forall a. Eq a => TreeMaybe a -> TreeMaybe a -> Bool
Eq)

instance Show (TreeMaybe (GovPurposeId p era)) where
  show :: TreeMaybe (GovPurposeId p era) -> String
show = (String
"\n" forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree String -> String
drawTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {p :: GovActionPurpose} {era}.
StrictMaybe (GovPurposeId p era) -> String
showGovPurposeId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TreeMaybe a -> Tree (StrictMaybe a)
unTreeMaybe
    where
      showGovPurposeId :: StrictMaybe (GovPurposeId p era) -> String
showGovPurposeId = \case
        StrictMaybe (GovPurposeId p era)
SNothing -> String
"x"
        SJust (GovPurposeId GovActionId (EraCrypto era)
govActionId) -> Text -> String
T.unpack (forall c. GovActionId c -> Text
govActionIdToText GovActionId (EraCrypto era)
govActionId)

-- | Partial version of `toGovRelationTreeEither`
toGovRelationTree :: (Era era, HasCallStack) => Proposals era -> GovRelation TreeMaybe era
toGovRelationTree :: forall era.
(Era era, ?callStack::CallStack) =>
Proposals era -> GovRelation TreeMaybe era
toGovRelationTree = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. (?callStack::CallStack) => String -> a
error forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
Era era =>
Proposals era -> Either String (GovRelation TreeMaybe era)
toGovRelationTreeEither

-- | Convert `Proposals` into a valid `Tree`
toGovRelationTreeEither :: Era era => Proposals era -> Either String (GovRelation TreeMaybe era)
toGovRelationTreeEither :: forall era.
Era era =>
Proposals era -> Either String (GovRelation TreeMaybe era)
toGovRelationTreeEither Proposals {OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps :: OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps :: forall era.
Proposals era
-> OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps, GovRelation PRoot era
pRoots :: GovRelation PRoot era
pRoots :: forall era. Proposals era -> GovRelation PRoot era
pRoots, GovRelation PGraph era
pGraph :: GovRelation PGraph era
pGraph :: forall era. Proposals era -> GovRelation PGraph era
pGraph} = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k v. Ord k => OMap k v -> Bool
OMap.invariantHolds' OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"OMap invariant is violated"

  let propsMap :: Map (GovActionId (EraCrypto era)) (GovActionState era)
propsMap = forall k v. OMap k v -> Map k v
OMap.toMap OMap (GovActionId (EraCrypto era)) (GovActionState era)
pProps
      childParentRelation :: GovRelation ChildParent era
childParentRelation = forall (f :: * -> *) era.
Foldable f =>
f (GovActionState era) -> GovRelation ChildParent era
toChildParentRelation Map (GovActionId (EraCrypto era)) (GovActionState era)
propsMap

  (TreeMaybe (GovPurposeId 'PParamUpdatePurpose era)
grPParamUpdate, Set (GovPurposeId 'PParamUpdatePurpose era)
nodesPParamUpdate) <-
    forall a.
(Ord a, Show a) =>
ChildParent a
-> PRoot a -> PGraph a -> Either String (TreeMaybe a, Set a)
toPTree (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'PParamUpdatePurpose era)
grPParamUpdate GovRelation ChildParent era
childParentRelation) (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'PParamUpdatePurpose era)
grPParamUpdate GovRelation PRoot era
pRoots) (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'PParamUpdatePurpose era)
grPParamUpdate GovRelation PGraph era
pGraph)
  (TreeMaybe (GovPurposeId 'HardForkPurpose era)
grHardFork, Set (GovPurposeId 'HardForkPurpose era)
nodesHardFork) <-
    forall a.
(Ord a, Show a) =>
ChildParent a
-> PRoot a -> PGraph a -> Either String (TreeMaybe a, Set a)
toPTree (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'HardForkPurpose era)
grHardFork GovRelation ChildParent era
childParentRelation) (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'HardForkPurpose era)
grHardFork GovRelation PRoot era
pRoots) (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'HardForkPurpose era)
grHardFork GovRelation PGraph era
pGraph)
  (TreeMaybe (GovPurposeId 'CommitteePurpose era)
grCommittee, Set (GovPurposeId 'CommitteePurpose era)
nodesCommittee) <-
    forall a.
(Ord a, Show a) =>
ChildParent a
-> PRoot a -> PGraph a -> Either String (TreeMaybe a, Set a)
toPTree (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'CommitteePurpose era)
grCommittee GovRelation ChildParent era
childParentRelation) (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'CommitteePurpose era)
grCommittee GovRelation PRoot era
pRoots) (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'CommitteePurpose era)
grCommittee GovRelation PGraph era
pGraph)
  (TreeMaybe (GovPurposeId 'ConstitutionPurpose era)
grConstitution, Set (GovPurposeId 'ConstitutionPurpose era)
nodesConstitution) <-
    forall a.
(Ord a, Show a) =>
ChildParent a
-> PRoot a -> PGraph a -> Either String (TreeMaybe a, Set a)
toPTree (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'ConstitutionPurpose era)
grConstitution GovRelation ChildParent era
childParentRelation) (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'ConstitutionPurpose era)
grConstitution GovRelation PRoot era
pRoots) (forall (f :: * -> *) era.
GovRelation f era -> f (GovPurposeId 'ConstitutionPurpose era)
grConstitution GovRelation PGraph era
pGraph)

  let allNodes :: Set (GovActionId (EraCrypto era))
allNodes =
        forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
          [ forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
unGovPurposeId Set (GovPurposeId 'PParamUpdatePurpose era)
nodesPParamUpdate
          , forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
unGovPurposeId Set (GovPurposeId 'HardForkPurpose era)
nodesHardFork
          , forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
unGovPurposeId Set (GovPurposeId 'CommitteePurpose era)
nodesCommittee
          , forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (p :: GovActionPurpose) era.
GovPurposeId p era -> GovActionId (EraCrypto era)
unGovPurposeId Set (GovPurposeId 'ConstitutionPurpose era)
nodesConstitution
          ]
      guardUnknown :: Either String ()
guardUnknown = do
        let unknown :: Set (GovActionId (EraCrypto era))
unknown = Set (GovActionId (EraCrypto era))
allNodes forall a. Ord a => Set a -> Set a -> Set a
Set.\\ forall k a. Map k a -> Set k
Map.keysSet Map (GovActionId (EraCrypto era)) (GovActionState era)
propsMap
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set (GovActionId (EraCrypto era))
unknown) forall a b. (a -> b) -> a -> b
$ do
          forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Discovered unrecognized nodes: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Set (GovActionId (EraCrypto era))
unknown
      guardUnique :: Either String ()
guardUnique = do
        let sumSizes :: Int
sumSizes =
              forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum
                [ forall a. Set a -> Int
Set.size Set (GovPurposeId 'PParamUpdatePurpose era)
nodesPParamUpdate
                , forall a. Set a -> Int
Set.size Set (GovPurposeId 'HardForkPurpose era)
nodesHardFork
                , forall a. Set a -> Int
Set.size Set (GovPurposeId 'CommitteePurpose era)
nodesCommittee
                , forall a. Set a -> Int
Set.size Set (GovPurposeId 'ConstitutionPurpose era)
nodesConstitution
                ]
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Int
Set.size Set (GovActionId (EraCrypto era))
allNodes forall a. Eq a => a -> a -> Bool
== Int
sumSizes) forall a b. (a -> b) -> a -> b
$ do
          forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
            String
"Duplicate govActionIds found between different purposes: "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
sumSizes forall a. Num a => a -> a -> a
- forall a. Set a -> Int
Set.size Set (GovActionId (EraCrypto era))
allNodes)
  Either String ()
guardUnknown
  Either String ()
guardUnique
  forall (f :: * -> *) a. Applicative f => a -> f a
pure GovRelation {TreeMaybe (GovPurposeId 'PParamUpdatePurpose era)
grPParamUpdate :: TreeMaybe (GovPurposeId 'PParamUpdatePurpose era)
grPParamUpdate :: TreeMaybe (GovPurposeId 'PParamUpdatePurpose era)
grPParamUpdate, TreeMaybe (GovPurposeId 'HardForkPurpose era)
grHardFork :: TreeMaybe (GovPurposeId 'HardForkPurpose era)
grHardFork :: TreeMaybe (GovPurposeId 'HardForkPurpose era)
grHardFork, TreeMaybe (GovPurposeId 'CommitteePurpose era)
grCommittee :: TreeMaybe (GovPurposeId 'CommitteePurpose era)
grCommittee :: TreeMaybe (GovPurposeId 'CommitteePurpose era)
grCommittee, TreeMaybe (GovPurposeId 'ConstitutionPurpose era)
grConstitution :: TreeMaybe (GovPurposeId 'ConstitutionPurpose era)
grConstitution :: TreeMaybe (GovPurposeId 'ConstitutionPurpose era)
grConstitution}

-- | Mapping from a child to a parent that was specified in the GovAction.
newtype ChildParent a = ChildParent (Map a (StrictMaybe a))
  deriving stock (Int -> ChildParent a -> ShowS
forall a. Show a => Int -> ChildParent a -> ShowS
forall a. Show a => [ChildParent a] -> ShowS
forall a. Show a => ChildParent a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChildParent a] -> ShowS
$cshowList :: forall a. Show a => [ChildParent a] -> ShowS
show :: ChildParent a -> String
$cshow :: forall a. Show a => ChildParent a -> String
showsPrec :: Int -> ChildParent a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ChildParent a -> ShowS
Show)
  deriving newtype (ChildParent a -> ChildParent a -> Bool
forall a. Eq a => ChildParent a -> ChildParent a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChildParent a -> ChildParent a -> Bool
$c/= :: forall a. Eq a => ChildParent a -> ChildParent a -> Bool
== :: ChildParent a -> ChildParent a -> Bool
$c== :: forall a. Eq a => ChildParent a -> ChildParent a -> Bool
Eq, NonEmpty (ChildParent a) -> ChildParent a
ChildParent a -> ChildParent a -> ChildParent a
forall b. Integral b => b -> ChildParent a -> ChildParent a
forall a. Ord a => NonEmpty (ChildParent a) -> ChildParent a
forall a. Ord a => ChildParent a -> ChildParent a -> ChildParent a
forall a b.
(Ord a, Integral b) =>
b -> ChildParent a -> ChildParent a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ChildParent a -> ChildParent a
$cstimes :: forall a b.
(Ord a, Integral b) =>
b -> ChildParent a -> ChildParent a
sconcat :: NonEmpty (ChildParent a) -> ChildParent a
$csconcat :: forall a. Ord a => NonEmpty (ChildParent a) -> ChildParent a
<> :: ChildParent a -> ChildParent a -> ChildParent a
$c<> :: forall a. Ord a => ChildParent a -> ChildParent a -> ChildParent a
Semigroup, ChildParent a
[ChildParent a] -> ChildParent a
ChildParent a -> ChildParent a -> ChildParent a
forall a. Ord a => Semigroup (ChildParent a)
forall a. Ord a => ChildParent a
forall a. Ord a => [ChildParent a] -> ChildParent a
forall a. Ord a => ChildParent a -> ChildParent a -> ChildParent a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ChildParent a] -> ChildParent a
$cmconcat :: forall a. Ord a => [ChildParent a] -> ChildParent a
mappend :: ChildParent a -> ChildParent a -> ChildParent a
$cmappend :: forall a. Ord a => ChildParent a -> ChildParent a -> ChildParent a
mempty :: ChildParent a
$cmempty :: forall a. Ord a => ChildParent a
Monoid)

toChildParentRelation ::
  Foldable f =>
  f (GovActionState era) ->
  GovRelation ChildParent era
toChildParentRelation :: forall (f :: * -> *) era.
Foldable f =>
f (GovActionState era) -> GovRelation ChildParent era
toChildParentRelation = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall {era}. GovActionState era -> GovRelation ChildParent era
toChildParent
  where
    toChildParent :: GovActionState era -> GovRelation ChildParent era
toChildParent GovActionState era
gas =
      forall era a.
GovActionState era
-> a
-> (forall (p :: GovActionPurpose).
    (forall (f :: * -> *).
     Lens' (GovRelation f era) (f (GovPurposeId p era)))
    -> StrictMaybe (GovPurposeId p era) -> GovPurposeId p era -> a)
-> a
withGovActionParent GovActionState era
gas forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL StrictMaybe (GovPurposeId p era)
parent GovPurposeId p era
_ ->
        forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Map a (StrictMaybe a) -> ChildParent a
ChildParent (forall k a. k -> a -> Map k a
Map.singleton (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId (GovActionState era
gas forall s a. s -> Getting a s a -> a
^. forall era.
Lens' (GovActionState era) (GovActionId (EraCrypto era))
gasIdL)) StrictMaybe (GovPurposeId p era)
parent)

toPTree ::
  (Ord a, Show a) =>
  ChildParent a ->
  PRoot a ->
  PGraph a ->
  Either String (TreeMaybe a, Set a)
toPTree :: forall a.
(Ord a, Show a) =>
ChildParent a
-> PRoot a -> PGraph a -> Either String (TreeMaybe a, Set a)
toPTree (ChildParent Map a (StrictMaybe a)
childParent) PRoot a
root (PGraph Map a (PEdges a)
fullGraph) = do
  (Map a (PEdges a)
_, Tree (StrictMaybe a)
tree) <- StrictMaybe a
-> Set a
-> Map a (PEdges a)
-> Either String (Map a (PEdges a), Tree (StrictMaybe a))
nodeToTree (forall a. PRoot a -> StrictMaybe a
prRoot PRoot a
root) (forall a. PRoot a -> Set a
prChildren PRoot a
root) Map a (PEdges a)
fullGraph
  [a]
nodesList <-
    case forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> (b -> a) -> StrictMaybe b -> a
strictMaybe (forall a b. a -> Either a b
Left ()) forall a b. b -> Either a b
Right) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Tree (StrictMaybe a)
tree of
      ([()]
roots, [a]
nodes)
        | forall a. StrictMaybe a -> Bool
isSNothing (forall a. PRoot a -> StrictMaybe a
prRoot PRoot a
root) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [()]
roots ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected an empty root, but it was not found in the Tree"
        | forall a. StrictMaybe a -> Bool
isSJust (forall a. PRoot a -> StrictMaybe a
prRoot PRoot a
root) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [()]
roots) ->
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Expected a full root, but got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [()]
roots) forall a. [a] -> [a] -> [a]
++ String
" Nothing cases"
        | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
nodes
  let nodes :: Set a
nodes = forall a. Ord a => [a] -> Set a
Set.fromList [a]
nodesList
      nodesWithoutRoot :: Set a
nodesWithoutRoot = forall a b. a -> (b -> a) -> StrictMaybe b -> a
strictMaybe Set a
nodes (forall a. Ord a => a -> Set a -> Set a
`Set.delete` Set a
nodes) (forall a. PRoot a -> StrictMaybe a
prRoot PRoot a
root)
      unreachable :: Map a (PEdges a)
unreachable = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys Map a (PEdges a)
fullGraph Set a
nodesWithoutRoot
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Set a -> Int
Set.size Set a
nodes forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
nodesList) forall a b. (a -> b) -> a -> b
$ do
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Detected duplicate nodes: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a.
(Foldable f, Ord a) =>
f a -> (Set a, OSet a)
OSet.fromFoldableDuplicates [a]
nodesList)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
Map.null Map a (PEdges a)
unreachable) forall a b. (a -> b) -> a -> b
$ do
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Discovered unreachable nodes in the graph: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Map a (PEdges a)
unreachable
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. Tree (StrictMaybe a) -> TreeMaybe a
TreeMaybe Tree (StrictMaybe a)
tree, Set a
nodesWithoutRoot)
  where
    nodeToTree :: StrictMaybe a
-> Set a
-> Map a (PEdges a)
-> Either String (Map a (PEdges a), Tree (StrictMaybe a))
nodeToTree StrictMaybe a
node Set a
children Map a (PEdges a)
graph = do
      (Map a (PEdges a)
graph', [Tree (StrictMaybe a)]
subTrees) <- forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM (StrictMaybe a
-> a
-> (Map a (PEdges a), [Tree (StrictMaybe a)])
-> Either String (Map a (PEdges a), [Tree (StrictMaybe a)])
childToTree StrictMaybe a
node) (Map a (PEdges a)
graph, []) Set a
children
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map a (PEdges a)
graph', forall a. a -> [Tree a] -> Tree a
Node StrictMaybe a
node [Tree (StrictMaybe a)]
subTrees)
    childToTree :: StrictMaybe a
-> a
-> (Map a (PEdges a), [Tree (StrictMaybe a)])
-> Either String (Map a (PEdges a), [Tree (StrictMaybe a)])
childToTree StrictMaybe a
parent a
child (!Map a (PEdges a)
graph, ![Tree (StrictMaybe a)]
acc) =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
child Map a (PEdges a)
graph of
        Maybe (PEdges a)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Cannot find the node: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
child
        Just PEdges a
edges -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. PEdges a -> StrictMaybe a
peParent PEdges a
edges forall a. Eq a => a -> a -> Bool
== StrictMaybe a
parent) forall a b. (a -> b) -> a -> b
$
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
              String
"Incorrect parent: "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. PEdges a -> StrictMaybe a
peParent PEdges a
edges)
                forall a. [a] -> [a] -> [a]
++ String
" listed for the node: "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
child
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
child Map a (StrictMaybe a)
childParent of
            Maybe (StrictMaybe a)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"Node is not found in the governance states map: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
child
            Just StrictMaybe a
trueParent
              | StrictMaybe a
trueParent forall a. Eq a => a -> a -> Bool
/= StrictMaybe a
parent ->
                  forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
                    String
"Parent of "
                      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
child
                      forall a. [a] -> [a] -> [a]
++ String
" specified in the GovAction: "
                      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StrictMaybe a
trueParent
                      forall a. [a] -> [a] -> [a]
++ String
" does not match the one on the Graph: "
                      forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show StrictMaybe a
parent
              | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          (Map a (PEdges a)
graph', !Tree (StrictMaybe a)
subTree) <-
            -- Deleting the child from the graph ensures that every node except the root
            -- appears exactly once in the graph.
            StrictMaybe a
-> Set a
-> Map a (PEdges a)
-> Either String (Map a (PEdges a), Tree (StrictMaybe a))
nodeToTree (forall a. a -> StrictMaybe a
SJust a
child) (forall a. PEdges a -> Set a
peChildren PEdges a
edges) (forall k a. Ord k => k -> Map k a -> Map k a
Map.delete a
child Map a (PEdges a)
graph)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map a (PEdges a)
graph', Tree (StrictMaybe a)
subTree forall a. a -> [a] -> [a]
: [Tree (StrictMaybe a)]
acc)

-- | Verify invariant after addition of GovActionState to Proposals. Will print the state
-- before the invariant is violated.
--
-- /Note/ - runs only when assertions are turned on.
checkInvariantAfterAddition ::
  (EraPParams era, HasCallStack) =>
  -- | GovAction that was added
  GovActionState era ->
  -- | Proposals before adding the GovActionState
  Proposals era ->
  -- | Proposals after adding the GovActionState
  Proposals era ->
  Proposals era
checkInvariantAfterAddition :: forall era.
(EraPParams era, ?callStack::CallStack) =>
GovActionState era
-> Proposals era -> Proposals era -> Proposals era
checkInvariantAfterAddition GovActionState era
gas Proposals era
psPre Proposals era
ps = forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
check Proposals era
ps
  where
    check :: Bool
check =
      case forall era.
Era era =>
Proposals era -> Either String (GovRelation TreeMaybe era)
toGovRelationTreeEither Proposals era
ps of
        Left String
err -> forall a. (?callStack::CallStack) => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Addition error: " forall a. [a] -> [a] -> [a]
++ String
err forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show GovActionState era
gas forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Proposals era
psPre
        Right GovRelation TreeMaybe era
_ -> Bool
True

-- | Verify invariant after deletion of GovActionState to Proposals. Will print the state
-- before the invariant is violated.
--
-- /Note/ - runs only when assertions are turned on.
checkInvariantAfterDeletion ::
  (EraPParams era, HasCallStack) =>
  -- | GovAction that was added
  Set (GovActionId (EraCrypto era)) ->
  -- | Proposals before adding the GovActionState
  Proposals era ->
  -- | Proposals after adding the GovActionState
  Proposals era ->
  Proposals era
checkInvariantAfterDeletion :: forall era.
(EraPParams era, ?callStack::CallStack) =>
Set (GovActionId (EraCrypto era))
-> Proposals era -> Proposals era -> Proposals era
checkInvariantAfterDeletion Set (GovActionId (EraCrypto era))
gais Proposals era
psPre Proposals era
ps = forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
check Proposals era
ps
  where
    check :: Bool
check =
      case forall era.
Era era =>
Proposals era -> Either String (GovRelation TreeMaybe era)
toGovRelationTreeEither Proposals era
ps of
        Left String
err -> forall a. (?callStack::CallStack) => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Deletion error: " forall a. [a] -> [a] -> [a]
++ String
err forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Set (GovActionId (EraCrypto era))
gais forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Proposals era
psPre
        Right GovRelation TreeMaybe era
_ -> Bool
True