type safe sorted votes/effects

2022-08-26 18:43:38 +08:00 · 2022-08-26 18:43:38 +08:00 · edee537ce2
commit edee537ce2
parent 6fbee1313d
10 changed files with 394 additions and 338 deletions
--- a/agora-specs/Sample/Proposal/Advance.hs
+++ b/agora-specs/Sample/Proposal/Advance.hs
@ -72,6 +72,7 @@ import Control.Applicative (liftA2)
 import Control.Monad.State (execState, modify, when)
 import Data.Default (def)
 import Data.List (singleton, sort)
+import Data.Map.Strict qualified as StrictMap
 import Data.Maybe (fromJust)
 import Data.Tagged (Tagged (..), untag)
 import Plutarch.Context (
@ -98,7 +99,6 @@ import PlutusLedgerApi.V2 (
  TxOutRef (TxOutRef),
  ValidatorHash,
 )
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (
  governorTxRef,
  proposalTxRef,
@ -134,7 +134,6 @@ import Test.Util (
  scriptHashes,
  sortValue,
  toDatum,
-  updateMap,
  validatorHashes,
 )

@ -251,20 +250,20 @@ outcomeIdxToResultTag = ResultTag . fromIntegral
 -- | Add a neutral effect group and allocate result tags for the effect groups.
 mkEffects ::
  ProposalParameters ->
-  AssocMap.Map ResultTag ProposalEffectGroup
+  StrictMap.Map ResultTag ProposalEffectGroup
 mkEffects ps =
  let resultTags = map ResultTag [0 ..]
-      neutralEffect = AssocMap.empty
+      neutralEffect = StrictMap.empty
      finalEffects = ps.effectList <> [neutralEffect]
-   in AssocMap.fromList $ zip resultTags finalEffects
+   in StrictMap.fromList $ zip resultTags finalEffects

 -- | Set the votes of the winning group(s).
 setWinner :: (Winner, Integer) -> ProposalVotes -> ProposalVotes
 setWinner (All, votes) (ProposalVotes m) =
-  ProposalVotes $ AssocMap.mapMaybe (const $ Just votes) m
+  ProposalVotes $ StrictMap.mapMaybe (const $ Just votes) m
 setWinner (EffectAt winnerIdx, votes) (ProposalVotes m) =
  let winnerResultTag = outcomeIdxToResultTag winnerIdx
-   in ProposalVotes $ updateMap (const $ Just votes) winnerResultTag m
+   in ProposalVotes $ StrictMap.adjust (const votes) winnerResultTag m

 -- | Mock votes for the proposal, given the parameters.
 mkVotes ::
@ -749,7 +748,7 @@ mkMockEffects useAuthScript n = effects

    effects =
      take n $
-        AssocMap.fromList
+        StrictMap.fromList
          <$> groupsOfN
            effectsPerGroup
            (zip effectScripts effectMetadata)
@ -852,8 +851,8 @@ mkValidToNextStateBundle nCosigners nEffects authScript from =
        when (from == Locked) $
          modify $ \b ->
            let aut =
-                  AssocMap.elems $
-                    AssocMap.mapWithKey
+                  StrictMap.elems $
+                    StrictMap.mapWithKey
                      ( \vh (_, authScript) ->
                          AuthorityTokenParameters
                            { mintGATsFor = vh
--- a/agora-specs/Sample/Proposal/Cosign.hs
+++ b/agora-specs/Sample/Proposal/Cosign.hs
@ -37,6 +37,7 @@ import Agora.Stake (
 import Data.Coerce (coerce)
 import Data.Default (def)
 import Data.List (sort)
+import Data.Map.Strict qualified as StrictMap
 import Data.Tagged (Tagged, untag)
 import Plutarch.Context (
  input,
@ -57,7 +58,6 @@ import PlutusLedgerApi.V2 (
  TxOutRef (..),
  Value,
 )
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
 import Sample.Shared (
  agoraScripts,
@ -101,9 +101,9 @@ perStakedGTs = 5
 mkProposalInputDatum :: Parameters -> ProposalDatum
 mkProposalInputDatum ps =
  let effects =
-        AssocMap.fromList
-          [ (ResultTag 0, AssocMap.empty)
-          , (ResultTag 1, AssocMap.empty)
+        StrictMap.fromList
+          [ (ResultTag 0, StrictMap.empty)
+          , (ResultTag 1, StrictMap.empty)
          ]
   in ProposalDatum
        { proposalId = ProposalId 0
--- a/agora-specs/Sample/Proposal/Create.hs
+++ b/agora-specs/Sample/Proposal/Create.hs
@ -17,7 +17,6 @@ module Sample.Proposal.Create (
  timeRangeNotTightParameters,
  timeRangeNotClosedParameters,
  invalidProposalStatusParameters,
-  unorderedEffectsParameters,
 ) where

 import Agora.Governor (
@ -47,6 +46,7 @@ import Agora.Stake (
 )
 import Data.Coerce (coerce)
 import Data.Default (Default (def))
+import Data.Map.Strict qualified as StrictMap
 import Data.Tagged (Tagged, untag)
 import Plutarch.Context (
  input,
@ -68,7 +68,6 @@ import PlutusLedgerApi.V2 (
  TxOutRef (TxOutRef),
  always,
 )
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (stakeTxRef)
 import Sample.Shared (
  agoraScripts,
@ -85,7 +84,13 @@ import Sample.Shared (
  stakeValidatorHash,
 )
 import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
-import Test.Util (CombinableBuilder, closedBoundedInterval, mkMinting, mkSpending, sortMap, sortValue)
+import Test.Util (
+  CombinableBuilder,
+  closedBoundedInterval,
+  mkMinting,
+  mkSpending,
+  sortValue,
+ )

 -- | Parameters for creating a proposal.
 data Parameters = Parameters
@ -105,8 +110,6 @@ data Parameters = Parameters
  -- ^ Is 'TxInfo.validTimeRange' closed?
  , proposalStatus :: ProposalStatus
  -- ^ The status of the newly created proposal.
-  , shuffleEffects :: Bool
-  -- ^ Effects will be unordered if this is set to true.
  }

 --------------------------------------------------------------------------------
@ -138,22 +141,12 @@ defLocks :: [ProposalLock]
 defLocks = [Created (ProposalId 0)]

 -- | The effect of the newly created proposal.
-defEffects :: AssocMap.Map ResultTag ProposalEffectGroup
+defEffects :: StrictMap.Map ResultTag ProposalEffectGroup
 defEffects =
-  sortMap $
-    AssocMap.fromList
-      [ (ResultTag 0, AssocMap.empty)
-      , (ResultTag 1, AssocMap.empty)
-      , (ResultTag 3, AssocMap.empty)
-      ]
-
-unorderedEffects :: AssocMap.Map ResultTag ProposalEffectGroup
-unorderedEffects =
-  AssocMap.fromList
-    [ (ResultTag 4, AssocMap.empty)
-    , (ResultTag 0, AssocMap.empty)
-    , (ResultTag 1, AssocMap.empty)
-    , (ResultTag 3, AssocMap.empty)
+  StrictMap.fromList
+    [ (ResultTag 0, StrictMap.empty)
+    , (ResultTag 1, StrictMap.empty)
+    , (ResultTag 3, StrictMap.empty)
    ]

 --------------------------------------------------------------------------------
@ -229,10 +222,7 @@ mkStakeOutputDatum ps =
 -}
 mkProposalOutputDatum :: Parameters -> ProposalDatum
 mkProposalOutputDatum ps =
-  let effects =
-        if ps.shuffleEffects
-          then unorderedEffects
-          else defEffects
+  let effects = defEffects
      votes = emptyVotesFor defEffects
   in ProposalDatum
        { proposalId = thisProposalId
@ -386,13 +376,6 @@ totallyValidParameters =
    , timeRangeTightEnough = True
    , timeRangeClosed = True
    , proposalStatus = Draft
-    , shuffleEffects = False
-    }
-
-unorderedEffectsParameters :: Parameters
-unorderedEffectsParameters =
-  totallyValidParameters
-    { shuffleEffects = True
    }

 invalidOutputGovernorDatumParameters :: Parameters
--- a/agora-specs/Sample/Proposal/UnlockStake.hs
+++ b/agora-specs/Sample/Proposal/UnlockStake.hs
@ -37,8 +37,13 @@ import Agora.Proposal (
 )
 import Agora.Proposal.Time (ProposalStartingTime (ProposalStartingTime))
 import Agora.Scripts (AgoraScripts (..))
-import Agora.Stake (ProposalLock (..), StakeDatum (..), StakeRedeemer (RetractVotes))
+import Agora.Stake (
+  ProposalLock (..),
+  StakeDatum (..),
+  StakeRedeemer (RetractVotes),
+ )
 import Data.Default.Class (Default (def))
+import Data.Map.Strict qualified as StrictMap
 import Data.Tagged (Tagged (..), untag)
 import Plutarch.Context (
  input,
@ -56,7 +61,6 @@ import PlutusLedgerApi.V2 (
  PubKeyHash,
  TxOutRef (..),
 )
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (stakeTxRef)
 import Sample.Shared (
  agoraScripts,
@ -69,7 +73,7 @@ import Sample.Shared (
  stakeValidatorHash,
 )
 import Test.Specification (SpecificationTree, group, testValidator)
-import Test.Util (CombinableBuilder, mkSpending, sortValue, updateMap)
+import Test.Util (CombinableBuilder, mkSpending, sortValue)

 --------------------------------------------------------------------------------

@ -77,7 +81,7 @@ import Test.Util (CombinableBuilder, mkSpending, sortValue, updateMap)
 votesTemplate :: ProposalVotes
 votesTemplate =
  ProposalVotes $
-    AssocMap.fromList
+    StrictMap.fromList
      [ (ResultTag 0, 0)
      , (ResultTag 1, 0)
      ]
@ -85,10 +89,10 @@ votesTemplate =
 -- | Create empty effects for every result tag given the votes.
 emptyEffectFor ::
  ProposalVotes ->
-  AssocMap.Map ResultTag ProposalEffectGroup
+  StrictMap.Map ResultTag ProposalEffectGroup
 emptyEffectFor (ProposalVotes vs) =
-  AssocMap.fromList $
-    map (,AssocMap.empty) (AssocMap.keys vs)
+  StrictMap.fromList $
+    map (,StrictMap.empty) (StrictMap.keys vs)

 -- | The default vote option that will be used by functions in this module.
 defVoteFor :: ResultTag
@ -236,12 +240,12 @@ mkProposalDatumPair params pid =
      ProposalVotes
    mkInputVotes Creator _ =
      ProposalVotes $
-        updateMap (Just . const 1000) defVoteFor $
+        StrictMap.adjust (const 1000) defVoteFor $
          getProposalVotes votesTemplate
    mkInputVotes Irrelevant _ = votesTemplate
    mkInputVotes _ vc =
      ProposalVotes $
-        updateMap (Just . const vc) defVoteFor $
+        StrictMap.adjust (const vc) defVoteFor $
          getProposalVotes votesTemplate

 -- | Create a 'TxInfo' that tries to unlock a stake.
--- a/agora-specs/Sample/Proposal/Vote.hs
+++ b/agora-specs/Sample/Proposal/Vote.hs
@ -31,6 +31,7 @@ import Agora.Stake (
  StakeRedeemer (PermitVote),
 )
 import Data.Default (Default (def))
+import Data.Map.Strict qualified as StrictMap
 import Data.Tagged (Tagged (Tagged), untag)
 import Plutarch.Context (
  input,
@ -49,7 +50,6 @@ import PlutusLedgerApi.V2 (
  PubKeyHash,
  TxOutRef (TxOutRef),
 )
-import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (proposalTxRef, stakeTxRef)
 import Sample.Shared (
  agoraScripts,
@ -67,7 +67,13 @@ import Test.Specification (
  testValidator,
  validatorSucceedsWith,
 )
-import Test.Util (CombinableBuilder, closedBoundedInterval, mkSpending, pubKeyHashes, sortValue, updateMap)
+import Test.Util (
+  CombinableBuilder,
+  closedBoundedInterval,
+  mkSpending,
+  pubKeyHashes,
+  sortValue,
+ )

 -- | Reference to the proposal UTXO.
 proposalRef :: TxOutRef
@ -92,9 +98,9 @@ stakeOwner :: PubKeyHash
 stakeOwner = signer

 -- | The votes of the input proposals.
-initialVotes :: AssocMap.Map ResultTag Integer
+initialVotes :: StrictMap.Map ResultTag Integer
 initialVotes =
-  AssocMap.fromList
+  StrictMap.fromList
    [ (ResultTag 0, 42)
    , (ResultTag 1, 4242)
    ]
@ -105,9 +111,9 @@ proposalInputDatum =
  ProposalDatum
    { proposalId = ProposalId 42
    , effects =
-        AssocMap.fromList
-          [ (ResultTag 0, AssocMap.empty)
-          , (ResultTag 1, AssocMap.empty)
+        StrictMap.fromList
+          [ (ResultTag 0, StrictMap.empty)
+          , (ResultTag 1, StrictMap.empty)
          ]
    , status = VotingReady
    , cosigners = [PubKeyCredential stakeOwner]
@ -168,8 +174,8 @@ vote params =

      ---

-      updatedVotes :: AssocMap.Map ResultTag Integer
-      updatedVotes = updateMap (Just . (+ params.voteCount)) params.voteFor initialVotes
+      updatedVotes :: StrictMap.Map ResultTag Integer
+      updatedVotes = StrictMap.adjust (+ params.voteCount) params.voteFor initialVotes

      ---