Merge pull request #67 from Liqwid-Labs/seungheonoh/effect-ptryfrom

Now `makeEffect` boilerplate requires datum to implemt `PTryFrom`

agora.cabal

@@ -123,6 +123,7 @@ library
   exposed-modules:
     Agora.AuthorityToken
     Agora.Effect
+    Agora.Effect.NoOp
     Agora.Governor
     Agora.MultiSig
     Agora.Proposal
@@ -151,11 +152,11 @@ test-suite agora-test
   main-is:        Spec.hs
   hs-source-dirs: agora-test
   other-modules:
+    Spec.AuthorityToken
     Spec.Model.MultiSig
     Spec.Sample.Stake
     Spec.Stake
     Spec.Util
-    Spec.AuthorityToken
 
   build-depends:  agora
 

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 ())

flake.nix

@@ -50,8 +50,10 @@
 
       projectFor = system:
         let pkgs = nixpkgsFor system;
-        in let pkgs' = nixpkgsFor' system;
-        in (nixpkgsFor system).haskell-nix.cabalProject' {
+        in
+        let pkgs' = nixpkgsFor' system;
+        in
+        (nixpkgsFor system).haskell-nix.cabalProject' {
           src = ./.;
           compiler-nix-name = ghcVersion;
           inherit (plutarch) cabalProjectLocal;
@@ -120,16 +122,18 @@
             inherit (plutarch.tools) fourmolu;
           })
             fourmolu;
-        in pkgs.runCommand "format-check" {
-          nativeBuildInputs = [
-            pkgs'.git
-            pkgs'.fd
-            pkgs'.haskellPackages.cabal-fmt
-            pkgs'.nixpkgs-fmt
-            fourmolu
-            pkgs'.haskell.packages."${ghcVersion}".hlint
-          ];
-        } ''
+        in
+        pkgs.runCommand "format-check"
+          {
+            nativeBuildInputs = [
+              pkgs'.git
+              pkgs'.fd
+              pkgs'.haskellPackages.cabal-fmt
+              pkgs'.nixpkgs-fmt
+              fourmolu
+              pkgs'.haskell.packages."${ghcVersion}".hlint
+            ];
+          } ''
           export LC_CTYPE=C.UTF-8
           export LC_ALL=C.UTF-8
           export LANG=C.UTF-8
@@ -139,20 +143,23 @@
           mkdir $out
         '';
 
-    in {
+    in
+    {
       project = perSystem projectFor;
       flake = perSystem (system: (projectFor system).flake { });
 
       packages = perSystem (system:
         self.flake.${system}.packages // {
-          haddock = let
-            agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
-            pkgs = nixpkgsFor system;
-          in pkgs.runCommand "haddock-merge" { } ''
-            cd ${self}
-            mkdir $out
-            cp -r ${agora-doc}/share/doc/* $out
-          '';
+          haddock =
+            let
+              agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
+              pkgs = nixpkgsFor system;
+            in
+            pkgs.runCommand "haddock-merge" { } ''
+              cd ${self}
+              mkdir $out
+              cp -r ${agora-doc}/share/doc/* $out
+            '';
         });
 
       # Define what we want to test
@@ -163,9 +170,10 @@
           agora-test = self.flake.${system}.packages."agora:test:agora-test";
         });
       check = perSystem (system:
-        (nixpkgsFor system).runCommand "combined-test" {
-          checksss = builtins.attrValues self.checks.${system};
-        } ''
+        (nixpkgsFor system).runCommand "combined-test"
+          {
+            checksss = builtins.attrValues self.checks.${system};
+          } ''
           echo $checksss
           touch $out
         '');