Merge pull request #157 from Liqwid-Labs/connor/effect-ref-script

Store `ScriptHash`es in the effects

agora-specs/Sample/Proposal/Advance.hs

@@ -44,6 +44,7 @@ import Agora.Governor (
  )
 import Agora.Proposal (
   ProposalDatum (..),
+  ProposalEffectGroup,
   ProposalId (ProposalId),
   ProposalRedeemer (AdvanceProposal),
   ProposalStatus (..),
@@ -67,10 +68,11 @@ import Agora.Stake (
   StakeRedeemer (WitnessStake),
  )
 import Agora.Utils (validatorHashToTokenName)
+import Control.Applicative (liftA2)
 import Control.Monad.State (execState, modify, when)
 import Data.Default (def)
-import Data.List (sort)
+import Data.List (singleton, sort)
-import Data.Maybe (catMaybes, fromJust)
+import Data.Maybe (fromJust)
 import Data.Tagged (Tagged (..), untag)
 import Plutarch.Context (
   input,
@@ -81,6 +83,7 @@ import Plutarch.Context (
   timeRange,
   withDatum,
   withRef,
+  withReferenceScript,
   withValue,
  )
 import Plutarch.Lift (PLifted, PUnsafeLiftDecl)
@@ -91,6 +94,7 @@ import PlutusLedgerApi.V2 (
   POSIXTime,
   POSIXTimeRange,
   PubKeyHash,
+  ScriptHash,
   TxOutRef (TxOutRef),
   ValidatorHash,
  )
@@ -127,6 +131,7 @@ import Test.Util (
   mkMinting,
   mkSpending,
   pubKeyHashes,
+  scriptHashes,
   sortValue,
   toDatum,
   updateMap,
@@ -144,7 +149,7 @@ data ParameterBundle = ParameterBundle
   , governorParameters :: Maybe GovernorParameters
   -- ^ Parameters related to GST moving. If set to 'Nothing', the GST won't
   --   be moved, thus the governor validator won't be run in 'mkTestTree'.
-  , authorityTokenParameters :: Maybe AuthorityTokenParameters
+  , authorityTokenParameters :: [AuthorityTokenParameters]
   -- ^ Parameters related to GAT minting. If set to 'Nothing', no GAT will
   --     be minted, thus the GAT minting policy won't be run in 'mkTestTree'.
   , transactionTimeRange :: POSIXTimeRange
@@ -171,10 +176,12 @@ data AuthorityTokenParameters = forall
   , PIsData pdatum
   ) =>
   AuthorityTokenParameters
-  { mintGATsFor :: [ValidatorHash]
+  { mintGATsFor :: ValidatorHash
   -- ^ GATs will be minted and sent to the given group of effects.
   , carryDatum :: Maybe datum
   -- ^ The datum that GAT UTxOs will be carrying.
+  , carryRefScript :: Maybe ScriptHash
+  -- ^ The reference script that GAT UTxOs will be carrying.
   , invalidTokenName :: Bool
   -- ^ If set to true, GATs won't be tagged by their corresponding effect
   --    hashes.
@@ -193,7 +200,7 @@ data ProposalParameters = ProposalParameters
   -- ^ What status is the proposal advancing from
   , toStatus :: ProposalStatus
   -- ^ What status is the proposal advancing to
-  , effectList :: [AssocMap.Map ValidatorHash DatumHash]
+  , effectList :: [ProposalEffectGroup]
   -- ^ The effect groups of the proposal. A neutral effect group is not
   --    required here.
   , winnerAndVotes :: Maybe (Winner, Integer)
@@ -244,7 +251,7 @@ outcomeIdxToResultTag = ResultTag . fromIntegral
 -- | Add a neutral effect group and allocate result tags for the effect groups.
 mkEffects ::
   ProposalParameters ->
-  AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+  AssocMap.Map ResultTag ProposalEffectGroup
 mkEffects ps =
   let resultTags = map ResultTag [0 ..]
       neutralEffect = AssocMap.empty
@@ -492,27 +499,24 @@ mkAuthorityTokenBuilder ::
   CombinableBuilder b =>
   AuthorityTokenParameters ->
   b
-mkAuthorityTokenBuilder (AuthorityTokenParameters es mdt invalidTokenName) =
+mkAuthorityTokenBuilder ps@AuthorityTokenParameters {carryDatum} =
-  foldMap perEffect es
+  let tn =
-  where
+        if ps.invalidTokenName
-    perEffect :: ValidatorHash -> b
+          then ""
-    perEffect vh =
+          else validatorHashToTokenName ps.mintGATsFor
-      let tn =
+      ac = AssetClass (authorityTokenSymbol, tn)
-            if invalidTokenName
+      minted = Value.assetClassValue ac 1
-              then ""
+      value = sortValue $ minAda <> minted
-              else validatorHashToTokenName vh
+   in mconcat
-          ac = AssetClass (authorityTokenSymbol, tn)
+        [ mint minted
-          minted = Value.assetClassValue ac 1
+        , output $
-          value = sortValue $ minAda <> minted
+            mconcat
-       in mconcat
+              [ script ps.mintGATsFor
-            [ mint minted
+              , maybe mempty withDatum carryDatum
-            , output $
+              , maybe mempty withReferenceScript ps.carryRefScript
-                mconcat
+              , withValue value
-                  [ script vh
+              ]
-                  , maybe mempty withDatum mdt
+        ]
-                  , withValue value
-                  ]
-            ]
 
 -- | The redeemer used while running the authority token policy.
 authorityTokenRedeemer :: ()
@@ -532,7 +536,7 @@ advance pb =
         [ mkProposalBuilder pb.proposalParameters
         , mkStakeBuilder pb.stakeParameters
         , mkBuilderMaybe mkGovernorBuilder pb.governorParameters
-        , mkBuilderMaybe mkAuthorityTokenBuilder pb.authorityTokenParameters
+        , foldMap mkAuthorityTokenBuilder pb.authorityTokenParameters
         , timeRange pb.transactionTimeRange
         , maybe mempty signedWith pb.extraSignature
         ]
@@ -548,14 +552,13 @@ mkTestTree ::
   Validity ->
   SpecificationTree
 mkTestTree name pb val =
-  group name $ catMaybes [proposal, stake, governor, authority]
+  group name $ mconcat [proposal, stake, governor, authority]
   where
     spend = mkSpending advance pb
-    mint = mkMinting advance pb
 
     proposal =
       let proposalInputDatum = mkProposalInputDatum pb.proposalParameters
-       in Just $
+       in singleton $
             testValidator
               val.forProposalValidator
               "proposal"
@@ -566,7 +569,7 @@ mkTestTree name pb val =
 
     stake =
       let idx = 0
-       in Just $
+       in singleton $
             testValidator
               val.forStakeValidator
               "stake"
@@ -577,23 +580,27 @@ mkTestTree name pb val =
               )
 
     governor =
-      testValidator
+      maybe [] singleton $
-        (fromJust val.forGovernorValidator)
+        testValidator
-        "governor"
+          (fromJust val.forGovernorValidator)
-        agoraScripts.compiledGovernorValidator
+          "governor"
-        governorInputDatum
+          agoraScripts.compiledGovernorValidator
-        governorRedeemer
+          governorInputDatum
-        (spend governorRef)
+          governorRedeemer
-        <$ pb.governorParameters
+          (spend governorRef)
+          <$ pb.governorParameters
 
-    authority =
+    authority = case pb.authorityTokenParameters of
-      testPolicy
+      [] -> []
-        (fromJust val.forAuthorityTokenPolicy)
+      _ ->
-        "authority"
+        singleton
-        agoraScripts.compiledAuthorityTokenPolicy
+          ( testPolicy
-        authorityTokenRedeemer
+              (fromJust val.forAuthorityTokenPolicy)
-        (mint authorityTokenSymbol)
+              "authority"
-        <$ (pb.authorityTokenParameters)
+              agoraScripts.compiledAuthorityTokenPolicy
+              authorityTokenRedeemer
+              (mkMinting advance pb authorityTokenSymbol)
+          )
 
 {- | Create a test tree that runs a bunch of parameter bundles. These bundles
       should have the same validity.
@@ -725,14 +732,26 @@ dummyDatumHash :: DatumHash
 dummyDatumHash = datumHash $ toDatum dummyDatum
 
 -- | Create given number of effect groups. Each group will have 3 effects.
-mkMockEffects :: Int -> [AssocMap.Map ValidatorHash DatumHash]
+mkMockEffects :: Bool -> Int -> [ProposalEffectGroup]
-mkMockEffects =
+mkMockEffects useRefScript n = effects
-  flip
+  where
-    take
+    effectsPerGroup = 3
-    ( AssocMap.fromList
+
-        . flip zip (repeat dummyDatumHash)
+    mkRefScripts True = Just <$> scriptHashes
-        <$> groupsOfN 3 validatorHashes
+    mkRefScripts False = repeat Nothing
-    )
+    refScripts = mkRefScripts useRefScript
+
+    datums = repeat dummyDatumHash
+
+    effectMetadata = zip datums refScripts
+    effectScripts = validatorHashes
+
+    effects =
+      take n $
+        AssocMap.fromList
+          <$> groupsOfN
+            effectsPerGroup
+            (zip effectScripts effectMetadata)
 
 numberOfVotesThatExceedsTheMinimumRequirement :: Integer
 numberOfVotesThatExceedsTheMinimumRequirement =
@@ -767,16 +786,18 @@ defaultWinnerIdx = 0
 mkValidToNextStateBundle ::
   -- | Number of cosigners.
   Word ->
-  -- | Number of effects
+  -- | Number of effects.
   Word ->
+  -- | Toggle the referenc script in GAT UTXO.
+  Bool ->
   -- | The initial proposal state, should not be 'Finished'.
   ProposalStatus ->
   ParameterBundle
-mkValidToNextStateBundle _ _ Finished =
+mkValidToNextStateBundle _ _ _ Finished =
   error "Cannot advance from Finished"
-mkValidToNextStateBundle nCosigners nEffects from =
+mkValidToNextStateBundle nCosigners nEffects refScript from =
   let next = getNextState from
-      effects = mkMockEffects $ fromIntegral nEffects
+      effects = mkMockEffects refScript $ fromIntegral nEffects
       winner = defaultWinnerIdx
 
       template =
@@ -800,7 +821,7 @@ mkValidToNextStateBundle nCosigners nEffects from =
                 , invalidStakeOutputDatum = False
                 }
           , governorParameters = Nothing
-          , authorityTokenParameters = Nothing
+          , authorityTokenParameters = []
           , transactionTimeRange = mkInTimeTimeRange from
           , extraSignature = Just signer
           }
@@ -830,18 +851,24 @@ mkValidToNextStateBundle nCosigners nEffects from =
         when (from == Locked) $
           modify $ \b ->
             let aut =
-                  AuthorityTokenParameters
+                  AssocMap.elems $
-                    { mintGATsFor = AssocMap.keys $ effects !! winner
+                    AssocMap.mapWithKey
-                    , carryDatum = Just dummyDatum
+                      ( \vh (_, refScript) ->
-                    , invalidTokenName = False
+                          AuthorityTokenParameters
-                    }
+                            { mintGATsFor = vh
+                            , carryDatum = Just dummyDatum
+                            , carryRefScript = refScript
+                            , invalidTokenName = False
+                            }
+                      )
+                      (effects !! winner)
                 gov =
                   GovernorParameters
                     { invalidGovernorOutputDatum = False
                     }
              in b
                   { governorParameters = Just gov
-                  , authorityTokenParameters = Just aut
+                  , authorityTokenParameters = aut
                   }
    in execState modifyTemplate template
 
@@ -852,11 +879,10 @@ mkValidToNextStateBundles ::
   Word ->
   [ParameterBundle]
 mkValidToNextStateBundles nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects
+  liftA2
-    <$> [ Draft
+    (mkValidToNextStateBundle nCosigners nEffects)
-        , VotingReady
+    [True, False]
-        , Locked
+    [Draft, VotingReady, Locked]
-        ]
 
 mkValidToFailedStateBundles ::
   -- | Number of cosigners
@@ -865,15 +891,14 @@ mkValidToFailedStateBundles ::
   Word ->
   [ParameterBundle]
 mkValidToFailedStateBundles nCosigners nEffects =
-  mkBundle
+  liftA2
-    <$> [ Draft
+    mkBundle
-        , VotingReady
+    [True, False]
-        , Locked
+    [Draft, VotingReady, Locked]
-        ]
   where
-    mkBundle from =
+    mkBundle refScript from =
       let next = Finished
-          effects = mkMockEffects $ fromIntegral nEffects
+          effects = mkMockEffects refScript $ fromIntegral nEffects
        in ParameterBundle
             { proposalParameters =
                 ProposalParameters
@@ -894,7 +919,7 @@ mkValidToFailedStateBundles nCosigners nEffects =
                   , invalidStakeOutputDatum = False
                   }
             , governorParameters = Nothing
-            , authorityTokenParameters = Nothing
+            , authorityTokenParameters = []
             , transactionTimeRange = mkTooLateTimeRange from
             , extraSignature = Just signer
             }
@@ -908,14 +933,13 @@ mkFromFinishedBundles ::
   Word ->
   [ParameterBundle]
 mkFromFinishedBundles nCosigners nEffects =
-  mkBundle
+  liftA2
-    <$> [ Draft
+    mkBundle
-        , VotingReady
+    [True, False]
-        , Locked
+    [Draft, VotingReady, Locked]
-        ]
   where
-    mkBundle from =
+    mkBundle refScript from =
-      let template = mkValidToNextStateBundle nCosigners nEffects from
+      let template = mkValidToNextStateBundle nCosigners nEffects refScript from
        in template
             { proposalParameters =
                 template.proposalParameters
@@ -926,24 +950,26 @@ mkFromFinishedBundles nCosigners nEffects =
 
 mkToNextStateTooLateBundles :: Word -> Word -> [ParameterBundle]
 mkToNextStateTooLateBundles nCosigners nEffects =
-  mkBundle
+  liftA2
-    <$> [ Draft
+    mkBundle
-        , VotingReady
+    [True, False]
-        , Locked
+    [Draft, VotingReady, Locked]
-        ]
   where
-    mkBundle from =
+    mkBundle refScript from =
-      let template = mkValidToNextStateBundle nCosigners nEffects from
+      let template = mkValidToNextStateBundle nCosigners nEffects refScript from
        in template
             { transactionTimeRange = mkTooLateTimeRange from
             }
 
 mkInvalidOutputStakeBundles :: Word -> Word -> [ParameterBundle]
 mkInvalidOutputStakeBundles nCosigners nEffects =
-  mkBundle <$> [Draft, VotingReady, Locked]
+  liftA2
+    mkBundle
+    [True, False]
+    [Draft, VotingReady, Locked]
   where
-    mkBundle from =
+    mkBundle refScript from =
-      let template = mkValidToNextStateBundle nCosigners nEffects from
+      let template = mkValidToNextStateBundle nCosigners nEffects refScript from
        in template
             { stakeParameters =
                 template.stakeParameters
@@ -965,7 +991,7 @@ mkInsufficientCosignsBundle nCosigners nEffects =
     insuffcientPerStakeGTs =
       untag (def :: ProposalThresholds).vote
         `div` fromIntegral nCosigners - 1
-    template = mkValidToNextStateBundle nCosigners nEffects Draft
+    template = mkValidToNextStateBundle nCosigners nEffects False Draft
 
 -- * From VotingReady
 
@@ -986,7 +1012,7 @@ mkInsufficientVotesBundle ::
   Word ->
   ParameterBundle
 mkInsufficientVotesBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects VotingReady
+  mkValidToNextStateBundle nCosigners nEffects False VotingReady
     `setWinnerAndVotes` Nothing
 
 mkAmbiguousWinnerBundle ::
@@ -994,14 +1020,14 @@ mkAmbiguousWinnerBundle ::
   Word ->
   ParameterBundle
 mkAmbiguousWinnerBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects VotingReady
+  mkValidToNextStateBundle nCosigners nEffects False VotingReady
     `setWinnerAndVotes` Just ambiguousWinnerVotes
 
 -- * From Locked
 
 mkValidFromLockedBundle :: Word -> Word -> ParameterBundle
 mkValidFromLockedBundle nCosigners nEffects =
-  mkValidToNextStateBundle nCosigners nEffects Locked
+  mkValidToNextStateBundle nCosigners nEffects False Locked
 
 mkMintGATsForWrongEffectsBundle ::
   Word ->
@@ -1010,17 +1036,11 @@ mkMintGATsForWrongEffectsBundle ::
 mkMintGATsForWrongEffectsBundle nCosigners nEffects =
   template
     { authorityTokenParameters =
-        ( \aut ->
+        take 4 $
-            aut
+          zipWith
-              { mintGATsFor =
+            (\a i -> a {mintGATsFor = validatorHashes !! i})
-                  [ validatorHashes !! 1
+            template.authorityTokenParameters
-                  , validatorHashes !! 3
+            [1, 3 ..]
-                  , validatorHashes !! 5
-                  , validatorHashes !! 7
-                  ]
-              }
-        )
-          <$> template.authorityTokenParameters
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
@@ -1031,7 +1051,7 @@ mkNoGATMintedBundle ::
   ParameterBundle
 mkNoGATMintedBundle nCosigners nEffects =
   template
-    { authorityTokenParameters = Nothing
+    { authorityTokenParameters = []
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
@@ -1059,16 +1079,19 @@ mkGATsWithWrongDatumBundle ::
   ParameterBundle
 mkGATsWithWrongDatumBundle nCosigners nEffects =
   template
-    { authorityTokenParameters = Just newAut
+    { authorityTokenParameters = newAut
     }
   where
     template = mkValidFromLockedBundle nCosigners nEffects
-    aut = fromJust template.authorityTokenParameters
     newAut =
-      AuthorityTokenParameters
+      ( \aut ->
-        aut.mintGATsFor
+          AuthorityTokenParameters
-        (Just (1 :: Integer))
+            aut.mintGATsFor
-        False
+            (Just (1 :: Integer))
+            aut.carryRefScript
+            False
+      )
+        <$> template.authorityTokenParameters
 
 mkBadGovernorOutputDatumBundle ::
   Word ->

agora-specs/Sample/Proposal/Create.hs

@@ -26,6 +26,7 @@ import Agora.Governor (
  )
 import Agora.Proposal (
   ProposalDatum (..),
+  ProposalEffectGroup,
   ProposalId (ProposalId),
   ProposalStatus (..),
   ResultTag (ResultTag),
@@ -60,12 +61,10 @@ import Plutarch.Context (
  )
 import PlutusLedgerApi.V1.Value qualified as Value
 import PlutusLedgerApi.V2 (
-  DatumHash,
   POSIXTime (POSIXTime),
   POSIXTimeRange,
   PubKeyHash,
   TxOutRef (TxOutRef),
-  ValidatorHash,
   always,
  )
 import PlutusTx.AssocMap qualified as AssocMap
@@ -136,7 +135,7 @@ defLocks :: [ProposalLock]
 defLocks = [Created (ProposalId 0)]
 
 -- | The effect of the newly created proposal.
-defEffects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+defEffects :: AssocMap.Map ResultTag ProposalEffectGroup
 defEffects =
   AssocMap.fromList
     [ (ResultTag 0, AssocMap.empty)

agora-specs/Sample/Proposal/UnlockStake.hs

@@ -28,6 +28,7 @@ module Sample.Proposal.UnlockStake (
 import Agora.Governor (Governor (..))
 import Agora.Proposal (
   ProposalDatum (..),
+  ProposalEffectGroup,
   ProposalId (..),
   ProposalRedeemer (Unlock),
   ProposalStatus (..),
@@ -51,10 +52,8 @@ import Plutarch.Context (
  )
 import PlutusLedgerApi.V1.Value qualified as Value
 import PlutusLedgerApi.V2 (
-  DatumHash,
   PubKeyHash,
   TxOutRef (..),
-  ValidatorHash,
  )
 import PlutusTx.AssocMap qualified as AssocMap
 import Sample.Proposal.Shared (stakeTxRef)
@@ -85,7 +84,7 @@ votesTemplate =
 -- | Create empty effects for every result tag given the votes.
 emptyEffectFor ::
   ProposalVotes ->
-  AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+  AssocMap.Map ResultTag ProposalEffectGroup
 emptyEffectFor (ProposalVotes vs) =
   AssocMap.fromList $
     map (,AssocMap.empty) (AssocMap.keys vs)

agora-testlib/Test/Util.hs

@@ -15,6 +15,7 @@ module Test.Util (
   sortValue,
   blake2b_224,
   pubKeyHashes,
+  scriptHashes,
   userCredentials,
   scriptCredentials,
   validatorHashes,
@@ -43,7 +44,6 @@ import Plutarch.Context (
  )
 import Plutarch.Crypto (pblake2b_256)
 import PlutusLedgerApi.V1.Interval qualified as PlutusTx
-import PlutusLedgerApi.V1.Scripts (Datum (Datum), DatumHash (DatumHash))
 import PlutusLedgerApi.V1.Value (Value (..))
 import PlutusLedgerApi.V2 (
   Credential (
@@ -51,8 +51,11 @@ import PlutusLedgerApi.V2 (
     ScriptCredential
   ),
   CurrencySymbol,
+  Datum (Datum),
+  DatumHash (DatumHash),
   PubKeyHash (..),
   ScriptContext,
+  ScriptHash (ScriptHash),
   TxOutRef,
   ValidatorHash (ValidatorHash),
  )
@@ -162,6 +165,10 @@ validatorHashes = ValidatorHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
 scriptCredentials :: [Credential]
 scriptCredentials = ScriptCredential <$> validatorHashes
 
+-- | An infinite list of *valid* script hashes.
+scriptHashes :: [ScriptHash]
+scriptHashes = ScriptHash . PlutusTx.toBuiltin <$> blake2b_224Hashes
+
 --------------------------------------------------------------------------------
 
 -- | Turn the given list in to groups which have the given length.

agora/Agora/Governor/Scripts.hs

@@ -28,6 +28,7 @@ import Agora.Governor (
  )
 import Agora.Proposal (
   PProposalDatum (..),
+  PProposalEffectGroup,
   ProposalStatus (Draft, Locked),
   phasNeutralEffect,
   pisEffectsVotesCompatible,
@@ -36,7 +37,14 @@ import Agora.Proposal (
   pwinner,
  )
 import Agora.Proposal.Time (createProposalStartingTime)
-import Agora.Scripts (AgoraScripts, authorityTokenSymbol, governorSTSymbol, proposalSTSymbol, proposalValidatoHash, stakeSTSymbol)
+import Agora.Scripts (
+  AgoraScripts,
+  authorityTokenSymbol,
+  governorSTSymbol,
+  proposalSTSymbol,
+  proposalValidatoHash,
+  stakeSTSymbol,
+ )
 import Agora.Stake (
   PProposalLock (..),
   PStakeDatum (..),
@@ -45,17 +53,17 @@ import Agora.Stake (
 import Agora.Utils (
   pfindDatum,
   pfromDatumHash,
+  pfstTuple,
   pmustFindDatum,
+  psndTuple,
   validatorHashToAddress,
  )
 import Plutarch.Api.V1 (
   PCurrencySymbol,
-  PMap,
-  PValidatorHash,
  )
+import Plutarch.Api.V1.AssocMap qualified as AssocMap
 import Plutarch.Api.V2 (
   PAddress,
-  PDatumHash,
   PMintingPolicy,
   PScriptPurpose (PMinting, PSpending),
   PTxOut,
@@ -66,10 +74,9 @@ import Plutarch.Extra.Field (pletAllC)
 import Plutarch.Extra.IsData (pmatchEnumFromData)
 import Plutarch.Extra.List (pfirstJust)
 import Plutarch.Extra.Map (
-  plookup,
   plookup',
  )
-import Plutarch.Extra.Maybe (passertPJust, pfromJust, pnothing)
+import Plutarch.Extra.Maybe (passertPDJust, passertPJust, pfromJust, pmaybeData, pnothing)
 import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
 import Plutarch.Extra.ScriptContext (
   pfindOutputsToAddress,
@@ -489,35 +496,44 @@ governorValidator as =
           pguardC "Output GATs is more than minted GATs" $
             plength # outputsWithGAT #== gatCount
 
-          let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PTxOut :--> PBool)
+          let validateGATOutput' :: Term s (PProposalEffectGroup :--> PTxOut :--> PBool)
-              gatOutputValidator' =
+              validateGATOutput' =
                 phoistAcyclic $
                   plam
-                    ( \effects output' -> unTermCont $ do
+                    ( \effects output -> unTermCont $ do
-                        output <- pletFieldsC @'["address", "datum"] output'
+                        outputF <- pletFieldsC @'["address", "datum", "referenceScript"] output
 
-                        let scriptHash =
+                        let receiverScriptHash =
-                              passertPJust # "GAT receiver is not a script"
+                              passertPJust # "GAT receiver should be a script"
-                                #$ pscriptHashFromAddress # output.address
+                                #$ pscriptHashFromAddress # outputF.address
-                            datumHash =
+                            effect =
-                              ptrace
+                              passertPJust # "Receiver should be in the effect group"
-                                "Output to effect should have datum"
+                                #$ AssocMap.plookup # receiverScriptHash # effects
-                                pfromDatumHash
+                            hasCorrectReferenceScript =
-                                # output.datum
+                              pmaybeData
-
+                                # pconstant True
-                            expectedDatumHash =
+                                # plam
-                              passertPJust # "Receiver is not in the effect list"
+                                  ( ( passertPDJust
-                                #$ plookup # scriptHash # effects
+                                        # "Output UTXO should have a reference script"
+                                        # outputF.referenceScript
+                                        #==
+                                    )
+                                      . pfromData
+                                  )
+                                # (psndTuple # effect)
+                            hasCorrectDatum =
+                              pfstTuple # effect #== pfromDatumHash # outputF.datum
 
                         pure $
                           foldr1
                             (#&&)
-                            [ ptraceIfFalse "GAT must be tagged by the effect hash" $ authorityTokensValidIn # patSymbol # output'
+                            [ ptraceIfFalse "GAT valid" $ authorityTokensValidIn # patSymbol # output
-                            , ptraceIfFalse "Unexpected datum" $ datumHash #== expectedDatumHash
+                            , ptraceIfFalse "Correct datum" hasCorrectDatum
+                            , ptraceIfFalse "Reference script correct" hasCorrectReferenceScript
                             ]
                     )
 
-              gatOutputValidator = gatOutputValidator' # effectGroup
+              validateGATOutput = validateGATOutput' # effectGroup
 
           pguardC "GATs valid" $
             pfoldr
@@ -526,7 +542,7 @@ governorValidator as =
                     let value = pfield @"value" # txOut
                         atValue = psymbolValueOf # patSymbol # value
                      in pif (atValue #== 0) r $
-                          pif (atValue #== 1) (r #&& gatOutputValidator # txOut) $ pconstant False
+                          pif (atValue #== 1) (r #&& validateGATOutput # txOut) $ pconstant False
                 )
               # pconstant True
               # pfromData txInfoF.outputs

agora/Agora/Plutarch/Orphans.hs

@@ -7,7 +7,7 @@
 
 module Agora.Plutarch.Orphans () where
 
-import Plutarch.Api.V1 (PDatumHash (..))
+import Plutarch.Api.V2 (PDatumHash (..), PScriptHash (..))
 import Plutarch.Builtin (PIsData (..))
 import Plutarch.Extra.TermCont (ptryFromC)
 import Plutarch.TryFrom (PTryFrom (..))
@@ -37,3 +37,18 @@ instance PTryFrom PData (PAsData PUnit)
 instance (PIsData a) => PIsData (PAsData a) where
   pfromDataImpl = punsafeCoerce
   pdataImpl = pdataImpl . pfromData
+
+-- | @since 1.0.0
+instance PTryFrom PData (PAsData PScriptHash) where
+  type PTryFromExcess PData (PAsData PScriptHash) = Flip Term PScriptHash
+  ptryFrom' opq = runTermCont $ do
+    (pfromData -> unwrapped, _) <- ptryFromC @(PAsData PByteString) opq
+
+    tcont $ \f ->
+      pif
+        -- Blake2b_224 hash: 224 bits/28 bytes.
+        (plengthBS # unwrapped #== 28)
+        (f ())
+        (ptraceError "ptryFrom(PScriptHash): must be 32 bytes long")
+
+    pure (punsafeCoerce opq, pcon $ PScriptHash unwrapped)

agora/Agora/Proposal.hs

@@ -11,6 +11,7 @@ module Agora.Proposal (
   -- * Haskell-land
 
   -- Proposal (..),
+  ProposalEffectGroup,
   ProposalDatum (..),
   ProposalRedeemer (..),
   ProposalStatus (..),
@@ -21,6 +22,7 @@ module Agora.Proposal (
   emptyVotesFor,
 
   -- * Plutarch-land
+  PProposalEffectGroup,
   PProposalDatum (..),
   PProposalRedeemer (..),
   PProposalStatus (..),
@@ -41,7 +43,12 @@ module Agora.Proposal (
 ) where
 
 import Agora.Plutarch.Orphans ()
-import Agora.Proposal.Time (PProposalStartingTime, PProposalTimingConfig, ProposalStartingTime, ProposalTimingConfig)
+import Agora.Proposal.Time (
+  PProposalStartingTime,
+  PProposalTimingConfig,
+  ProposalStartingTime,
+  ProposalTimingConfig,
+ )
 import Agora.SafeMoney (GTTag)
 import Data.Tagged (Tagged)
 import Generics.SOP qualified as SOP
@@ -50,7 +57,10 @@ import Plutarch.Api.V1.AssocMap qualified as PAssocMap
 import Plutarch.Api.V2 (
   KeyGuarantees (Unsorted),
   PDatumHash,
+  PMaybeData,
   PPubKeyHash,
+  PScriptHash,
+  PTuple,
  )
 import Plutarch.DataRepr (DerivePConstantViaData (..), PDataFields)
 import Plutarch.Extra.Comonad (pextract)
@@ -75,7 +85,7 @@ import Plutarch.Lift (
  )
 import Plutarch.SafeMoney (PDiscrete (..))
 import Plutarch.Show (PShow (..))
-import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
+import PlutusLedgerApi.V2 (DatumHash, PubKeyHash, ScriptHash, ValidatorHash)
 import PlutusTx qualified
 import PlutusTx.AssocMap qualified as AssocMap
 
@@ -272,6 +282,9 @@ newtype ProposalVotes = ProposalVotes
 emptyVotesFor :: forall a. AssocMap.Map ResultTag a -> ProposalVotes
 emptyVotesFor = ProposalVotes . AssocMap.mapWithKey (const . const 0)
 
+-- | @since 0.3.0
+type ProposalEffectGroup = AssocMap.Map ValidatorHash (DatumHash, Maybe ScriptHash)
+
 {- | Haskell-level datum for Proposal scripts.
 
      @since 0.1.0
@@ -282,7 +295,7 @@ data ProposalDatum = ProposalDatum
   -- TODO: could we encode this more efficiently?
   -- This is shaped this way for future proofing.
   -- See https://github.com/Liqwid-Labs/agora/issues/39
-  , effects :: AssocMap.Map ResultTag (AssocMap.Map ValidatorHash DatumHash)
+  , effects :: AssocMap.Map ResultTag ProposalEffectGroup
   -- ^ Effect lookup table. First by result, then by effect hash.
   , status :: ProposalStatus
   -- ^ The status the proposal is in.
@@ -583,6 +596,15 @@ deriving via
   instance
     (PConstantDecl ProposalVotes)
 
+type PProposalEffectGroup =
+  PMap
+    'Unsorted
+    PValidatorHash
+    ( PTuple
+        PDatumHash
+        (PMaybeData (PAsData PScriptHash))
+    )
+
 {- | Plutarch-level version of 'ProposalDatum'.
 
      @since 0.1.0
@@ -593,7 +615,7 @@ newtype PProposalDatum (s :: S) = PProposalDatum
         s
         ( PDataRecord
             '[ "proposalId" ':= PProposalId
-             , "effects" ':= PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+             , "effects" ':= PMap 'Unsorted PResultTag PProposalEffectGroup
              , "status" ':= PProposalStatus
              , "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
              , "thresholds" ':= PProposalThresholds
@@ -678,7 +700,7 @@ phasNeutralEffect ::
   forall (s :: S).
   Term
     s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Unsorted PResultTag PProposalEffectGroup
         :--> PBool
     )
 phasNeutralEffect = phoistAcyclic $ PAssocMap.pany # PAssocMap.pnull
@@ -691,7 +713,7 @@ pisEffectsVotesCompatible ::
   forall (s :: S).
   Term
     s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Unsorted PResultTag PProposalEffectGroup
         :--> PProposalVotes
         :--> PBool
     )
@@ -811,7 +833,7 @@ phighestVotes = phoistAcyclic $
 pneutralOption ::
   Term
     s
-    ( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
+    ( PMap 'Unsorted PResultTag PProposalEffectGroup
         :--> PResultTag
     )
 pneutralOption = phoistAcyclic $

agora/Agora/Proposal/Time.hs

@@ -44,8 +44,9 @@ import Plutarch.DataRepr (
   PDataFields,
  )
 import Plutarch.Extra.Applicative (PApply (pliftA2))
+import Plutarch.Extra.Bind ((#>>=))
 import Plutarch.Extra.Field (pletAll, pletAllC)
-import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing)
+import Plutarch.Extra.Maybe (pjust, pnothing)
 import Plutarch.Extra.TermCont (pmatchC)
 import Plutarch.Lift (
   DerivePConstantViaNewtype (..),
@@ -357,8 +358,7 @@ createProposalStartingTime = phoistAcyclic $
                       "createProposalStartingTime: given time range should be tight enough"
                       pnothing
                   )
-     in -- TODO: PMonad when?
+     in ct #>>= f
-        pmaybe # pnothing # f # ct
 
 {- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
 

agora/Agora/Utils.hs

@@ -24,6 +24,8 @@ module Agora.Utils (
   pfromDatumHash,
   pfromInlineDatum,
   ptryFindDatum,
+  pfstTuple,
+  psndTuple,
 ) where
 
 import Plutarch.Api.V1.AssocMap (KeyGuarantees (Unsorted), PMap)
@@ -32,6 +34,7 @@ import Plutarch.Api.V2 (
   PDatum,
   PDatumHash,
   POutputDatum (..),
+  PTuple,
  )
 import Plutarch.Extra.Functor (pfmap)
 import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
@@ -235,3 +238,17 @@ infixr 8 #.**
   Term s c ->
   Term s e
 (#.**) f g x y z = f #$ g # x # y # z
+
+{- | Extract the first component of a 'PTuple'.
+
+     @since 1.0.0
+-}
+pfstTuple :: forall a b s. (PIsData a) => Term s (PTuple a b :--> a)
+pfstTuple = phoistAcyclic $ plam $ pfromData . (pfield @"_0" #)
+
+{- | Extract the second component of a 'PTuple'.
+
+     @since 1.0.0
+-}
+psndTuple :: forall b a s. (PIsData b) => Term s (PTuple a b :--> b)
+psndTuple = phoistAcyclic $ plam $ pfromData . (pfield @"_1" #)

flake.lock

@@ -12940,16 +12940,16 @@
         "plutarch": "plutarch_7"
       },
       "locked": {
-        "lastModified": 1660151677,
+        "lastModified": 1660709756,
-        "narHash": "sha256-sUdXtVdCpm7pgmw0f+b0FyF4Bf0VX+1kTY5U8O3H4uk=",
+        "narHash": "sha256-L9S9UYtpeTVGFmKNj8c/H3i17Jx8asCiW43xblN5nBo=",
         "owner": "Liqwid-Labs",
         "repo": "plutarch-context-builder",
-        "rev": "7033ca3c18968cfd206afbbd40861a0a778b414c",
+        "rev": "cc91cd134ce01e280df3b0ce09a25ede54dbf9b6",
         "type": "github"
       },
       "original": {
         "owner": "Liqwid-Labs",
-        "ref": "staging",
+        "ref": "main",
         "repo": "plutarch-context-builder",
         "type": "github"
       }

flake.nix

@@ -32,7 +32,7 @@
     plutarch-quickcheck.url =
       "github:liqwid-labs/plutarch-quickcheck?ref=staging";
     plutarch-context-builder.url =
-      "github:Liqwid-Labs/plutarch-context-builder?ref=staging";
+      "github:Liqwid-Labs/plutarch-context-builder?ref=main";
     plutarch-script-export.url =
       "github:Liqwid-Labs/plutarch-script-export?ref=main";