Merge branch 'master' into seungheonoh/treasurywithdrawaleffect

agora.cabal

@@ -124,6 +124,7 @@ library
     Agora.AuthorityToken
     Agora.Effect
     Agora.Effect.TreasuryWithdrawal
+    Agora.Effect.NoOp
     Agora.Governor
     Agora.MultiSig
     Agora.Proposal

agora/Agora/Effect.hs

@@ -5,17 +5,13 @@ Description: Helpers for constructing effects
 
 Helpers for constructing effects.
 -}
-module Agora.Effect (
-  makeEffect,
-  noopEffect,
-) where
+module Agora.Effect (makeEffect) where
 
 import Agora.AuthorityToken (singleAuthorityTokenBurned)
 import Agora.Utils (passert)
-import Plutarch (popaque)
 import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
-import Plutarch.Internal (punsafeCoerce)
 import Plutarch.Monadic qualified as P
+import Plutarch.TryFrom (PTryFrom, ptryFrom)
 import Plutus.V1.Ledger.Value (CurrencySymbol)
 
 --------------------------------------------------------------------------------
@@ -28,7 +24,7 @@ import Plutus.V1.Ledger.Value (CurrencySymbol)
 -}
 makeEffect ::
   forall (datum :: PType).
-  PIsData datum =>
+  (PIsData datum, PTryFrom PData datum) =>
   CurrencySymbol ->
   (forall (s :: S). Term s PCurrencySymbol -> Term s datum -> Term s PTxOutRef -> Term s (PAsData PTxInfo) -> Term s POpaque) ->
   ClosedTerm PValidator
@@ -37,29 +33,24 @@ makeEffect gatCs' f =
     ctx <- pletFields @'["txInfo", "purpose"] ctx'
     txInfo' <- plet ctx.txInfo
 
-    -- TODO: Use PTryFrom
-    let datum' :: Term _ datum
-        datum' = pfromData $ punsafeCoerce datum
+    -- convert input datum, PData, into desierable type
+    -- the way this conversion is performed should be defined
+    -- by PTryFrom for each datum in effect script.
+    (datum', _) <- ptryFrom @datum datum
 
+    -- ensure purpose is Spending.
     PSpending txOutRef <- pmatch $ pfromData ctx.purpose
     txOutRef' <- plet (pfield @"_0" # txOutRef)
 
+    -- fetch minted values to ensure single GAT is burned
     txInfo <- pletFields @'["mint"] txInfo'
     let mint :: Term _ PValue
         mint = txInfo.mint
 
+    -- fetch script context
     gatCs <- plet $ pconstant gatCs'
 
     passert "A single authority token has been burned" $ singleAuthorityTokenBurned gatCs txInfo' mint
 
+    -- run effect function
     f gatCs datum' txOutRef' txInfo'
-
---------------------------------------------------------------------------------
-
--- | Dummy effect which can only burn its GAT.
-noopEffect :: CurrencySymbol -> ClosedTerm PValidator
-noopEffect =
-  ( `makeEffect`
-      \_gatCs (_datum :: Term _ PUnit) _txOutRef _txInfo -> P.do
-        popaque (pconstant ())
-  )

agora/Agora/Effect/NoOp.hs

@@ -0,0 +1,33 @@
+{- |
+Module     : Agora.Effect.NoOp
+Maintainer : seungheon.ooh@gmail.com
+Description: Dummy dumb dumb effect.
+
+A dumb effect that only burns its GAT.
+-}
+module Agora.Effect.NoOp (noOpValidator, PNoOp) where
+
+import Control.Applicative (Const)
+
+import Agora.Effect (makeEffect)
+import Plutarch (popaque)
+import Plutarch.Api.V1 (PValidator)
+import Plutarch.TryFrom (PTryFrom (..))
+import Plutus.V1.Ledger.Value (CurrencySymbol)
+
+newtype PNoOp (s :: S) = PNoOp (Term s PUnit)
+  deriving (PlutusType, PIsData) via (DerivePNewtype PNoOp PUnit)
+
+instance PTryFrom PData PNoOp where
+  type PTryFromExcess PData PNoOp = Const ()
+  ptryFrom' _ cont =
+    -- JUSTIFICATION:
+    -- We don't care anything about data.
+    -- It should always be reduced to Unit.
+    cont (pcon $ PNoOp (pconstant ()), ())
+
+-- | Dummy effect which can only burn its GAT.
+noOpValidator :: CurrencySymbol -> ClosedTerm PValidator
+noOpValidator curr = makeEffect curr $
+  \_ (_datum :: Term s PNoOp) _ _ -> P.do
+    popaque (pconstant ())