From 097e055f199717c44299a48c9bfe6117b0bb183b Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Wed, 30 Mar 2022 15:32:50 +0200 Subject: [PATCH] use plutarch-safemoney instead of local Agora.SafeMoney --- agora-test/Spec/Sample/Stake.hs | 13 ++-- agora.cabal | 1 + agora/Agora/Proposal.hs | 9 ++- agora/Agora/SafeMoney.hs | 125 ++------------------------------ agora/Agora/Stake.hs | 78 ++++++++++---------- flake.lock | 14 ++-- flake.nix | 14 +++- 7 files changed, 75 insertions(+), 179 deletions(-) diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index 85b95ac..e0ed848 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -51,8 +51,9 @@ import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- -import Agora.SafeMoney +import Agora.SafeMoney (GTTag) import Agora.Stake +import Plutarch.SafeMoney import Spec.Util (datumPair, toDatumHash) -------------------------------------------------------------------------------- @@ -62,7 +63,7 @@ stake :: Stake stake = Stake { gtClassRef = - AssetClassRef + Tagged ( AssetClass ( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24" , "LQ" @@ -143,9 +144,9 @@ stakeCreationUnsigned = -- | Config for creating a ScriptContext that deposits or withdraws. data DepositWithdrawExample = DepositWithdrawExample - { startAmount :: Discrete GTTag + { startAmount :: Tagged GTTag Integer -- ^ The amount of GT stored before the transaction. - , delta :: Discrete GTTag + , delta :: Tagged GTTag Integer -- ^ The amount of GT deposited or withdrawn from the Stake. } @@ -168,7 +169,7 @@ stakeDepositWithdraw config = { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , txOutValue = st - <> discreteValue stake.gtClassRef stakeBefore.stakedAmount + <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeBefore.stakedAmount) , txOutDatumHash = Just (toDatumHash stakeAfter) } ] @@ -177,7 +178,7 @@ stakeDepositWithdraw config = { txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing , txOutValue = st - <> discreteValue stake.gtClassRef stakeAfter.stakedAmount + <> Value.assetClassValue (untag stake.gtClassRef) (untag stakeAfter.stakedAmount) , txOutDatumHash = Just (toDatumHash stakeAfter) } ] diff --git a/agora.cabal b/agora.cabal index 3afdca4..046a5c8 100644 --- a/agora.cabal +++ b/agora.cabal @@ -97,6 +97,7 @@ common deps , plutarch , plutarch-extra , plutarch-numeric + , plutarch-safemoney , plutus-core , plutus-ledger-api , plutus-tx diff --git a/agora/Agora/Proposal.hs b/agora/Agora/Proposal.hs index ddad144..a5dbbd9 100644 --- a/agora/Agora/Proposal.hs +++ b/agora/Agora/Proposal.hs @@ -38,7 +38,8 @@ import PlutusTx qualified -------------------------------------------------------------------------------- -import Agora.SafeMoney (Discrete, GTTag, PDiscrete) +import Agora.SafeMoney (GTTag) +import Plutarch.SafeMoney (PDiscrete, Tagged) -------------------------------------------------------------------------------- -- Haskell-land @@ -92,11 +93,11 @@ PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('F to 'Proposal's when they are created. -} data ProposalThresholds = ProposalThresholds - { execute :: Discrete GTTag + { execute :: Tagged GTTag Integer -- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass. - , draft :: Discrete GTTag + , draft :: Tagged GTTag Integer -- ^ How much GT required to "create" a proposal. - , vote :: Discrete GTTag + , vote :: Tagged GTTag Integer -- ^ How much GT required to allow voting to happen. -- (i.e. to move into 'VotingReady') } diff --git a/agora/Agora/SafeMoney.hs b/agora/Agora/SafeMoney.hs index d8c3da0..8791ff9 100644 --- a/agora/Agora/SafeMoney.hs +++ b/agora/Agora/SafeMoney.hs @@ -1,51 +1,21 @@ {- | Module : Agora.SafeMoney Maintainer : emi@haskell.fyi -Description: Phantom-type protected types for handling money in Plutus. +Description: Tags and bonuses for Plutarch.SafeMoney. -Phantom-type protected types for handling money in Plutus. +Tags and bonuses for "Plutarch.SafeMoney". -} module Agora.SafeMoney ( - -- * Types - PDiscrete (..), - Discrete (..), - - -- * Tags and refs - AssetClassRef (..), ADATag, GTTag, adaRef, - - -- * Utility functions - paddDiscrete, - pgeqDiscrete, - pzeroDiscrete, - - -- * Conversions - pdiscreteValue, - pvalueDiscrete, - discreteValue, ) where -import Prelude - -------------------------------------------------------------------------------- -import Plutus.V1.Ledger.Value (AssetClass (AssetClass), Value) -import Plutus.V1.Ledger.Value qualified as Value -import PlutusTx qualified +import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -import Plutarch.Api.V1 (PValue) -import Plutarch.Builtin () -import Plutarch.Internal () -import Plutarch.Monadic qualified as P - --------------------------------------------------------------------------------- - -import Agora.Utils ( - passetClassValueOf', - psingletonValue, - ) +import Plutarch.SafeMoney -------------------------------------------------------------------------------- -- Example tags @@ -58,89 +28,6 @@ data ADATag -------------------------------------------------------------------------------- --- | A tagged AssetClass. Use to resolve a reference inside of a PDiscrete -newtype AssetClassRef (tag :: Type) = AssetClassRef {getAssetClass :: AssetClass} - -- | Resolves ada tags. -adaRef :: AssetClassRef ADATag -adaRef = AssetClassRef (AssetClass ("", "")) - --- TODO: Currently it's possible to transmute from one discrete to another. --- How do we prevent this? --- --- @ --- transmute :: forall (a :: Type) (b :: Type). Discrete a -> Discrete b --- transmute = Discrete . getDiscrete --- @ - -{- | Represents a single asset in a 'Plutus.V1.Ledger.Value.Value' related to a particular 'AssetClass' - through 'AssetClassRef'. --} -newtype Discrete (tag :: Type) = Discrete {getDiscrete :: Integer} - deriving stock (Show, Eq) - deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData) - deriving newtype (Num) -- TODO: Use plutarch-numeric - -{- | Represents a single asset in a 'PValue' related to a particular 'AssetClass' - through 'AssetClassRef'. --} -newtype PDiscrete (tag :: Type) (s :: S) - = PDiscrete (Term s PInteger) - deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete tag) PInteger) - --- | Check if one 'PDiscrete' is greater than another. -pgeqDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PBool) -pgeqDiscrete = phoistAcyclic $ - plam $ \x y -> P.do - PDiscrete x' <- pmatch x - PDiscrete y' <- pmatch y - y' #<= x' - --- | Returns a zero-value 'PDiscrete' unit for any tag. -pzeroDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag) -pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0) - --- | Add two 'PDiscrete' values of the same tag. -paddDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PDiscrete tag) -paddDiscrete = phoistAcyclic $ - -- In the future, this should use plutarch-numeric - plam $ \x y -> P.do - PDiscrete x' <- pmatch x - PDiscrete y' <- pmatch y - pcon (PDiscrete $ x' + y') - --------------------------------------------------------------------------------- - --- | Downcast a `PValue` to a `PDiscrete` unit. -pvalueDiscrete :: - forall (tag :: Type) (s :: S). - AssetClassRef tag -> - Term s (PValue :--> PDiscrete tag) -pvalueDiscrete (AssetClassRef ac) = phoistAcyclic $ - plam $ \f -> - pcon . PDiscrete $ passetClassValueOf' ac # f - -{- | Get a `PValue` from a `PDiscrete`. - __NOTE__: `pdiscreteValue` after `pvalueDiscrete` is not a round-trip. - It filters for a particular tag. --} -pdiscreteValue :: - forall (tag :: Type) (s :: S). - AssetClassRef tag -> - Term s (PDiscrete tag :--> PValue) -pdiscreteValue (AssetClassRef (AssetClass (cs, tn))) = phoistAcyclic $ - plam $ \f -> pmatch f $ \case - PDiscrete p -> - psingletonValue - # pconstant cs - # pconstant tn - # p - --- | Get a `Value` from a `Discrete`. -discreteValue :: - forall (tag :: Type). - AssetClassRef tag -> - Discrete tag -> - Value -discreteValue (AssetClassRef (AssetClass (cs, tn))) (Discrete v) = - Value.singleton cs tn v +adaRef :: Tagged ADATag AssetClass +adaRef = Tagged (AssetClass ("", "")) diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 67184bf..ff362e0 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -22,7 +22,7 @@ module Agora.Stake ( import GHC.Generics qualified as GHC import Generics.SOP (Generic, I (I)) -import Prelude +import Prelude hiding (Num (..)) -------------------------------------------------------------------------------- @@ -52,16 +52,7 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass)) -------------------------------------------------------------------------------- -import Agora.SafeMoney ( - AssetClassRef (..), - Discrete, - GTTag, - PDiscrete, - paddDiscrete, - pdiscreteValue, - pgeqDiscrete, - pzeroDiscrete, - ) +import Agora.SafeMoney (GTTag) import Agora.Utils ( anyInput, anyOutput, @@ -77,38 +68,41 @@ import Agora.Utils ( ptxSignedBy, pvalueSpent, ) +import Plutarch.Numeric +import Plutarch.SafeMoney ( + PDiscrete, + Tagged (..), + pdiscreteValue, + untag, + ) -------------------------------------------------------------------------------- -- | Parameters for creating Stake scripts. newtype Stake = Stake - { gtClassRef :: AssetClassRef GTTag + { gtClassRef :: Tagged GTTag AssetClass -- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code. } --- | Plutarch-level redeemer for Stake scripts. -data PStakeRedeemer (s :: S) - = -- | Deposit or withdraw a discrete amount of the staked governance token. - PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag])) - | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. - PDestroy (Term s (PDataRecord '[])) - deriving stock (GHC.Generic) - deriving anyclass (Generic) - deriving anyclass (PIsDataRepr) - deriving - (PlutusType, PIsData) - via PIsDataReprInstances PStakeRedeemer - -- | Haskell-level redeemer for Stake scripts. data StakeRedeemer = -- | Deposit or withdraw a discrete amount of the staked governance token. - DepositWithdraw (Discrete GTTag) + DepositWithdraw (Tagged GTTag Integer) | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. Destroy deriving stock (Show, GHC.Generic) PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)] +-- | Haskell-level datum for Stake scripts. +data StakeDatum = StakeDatum + { stakedAmount :: Tagged GTTag Integer + , owner :: PubKeyHash + } + deriving stock (Show, GHC.Generic) + +PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)] + -- | Plutarch-level datum for Stake scripts. newtype PStakeDatum (s :: S) = PStakeDatum { getStakeDatum :: @@ -121,14 +115,18 @@ newtype PStakeDatum (s :: S) = PStakeDatum (PlutusType, PIsData, PDataFields) via (PIsDataReprInstances PStakeDatum) --- | Haskell-level datum for Stake scripts. -data StakeDatum = StakeDatum - { stakedAmount :: Discrete GTTag - , owner :: PubKeyHash - } - deriving stock (Show, GHC.Generic) - -PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)] +-- | Plutarch-level redeemer for Stake scripts. +data PStakeRedeemer (s :: S) + = -- | Deposit or withdraw a discrete amount of the staked governance token. + PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag])) + | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. + PDestroy (Term s (PDataRecord '[])) + deriving stock (GHC.Generic) + deriving anyclass (Generic) + deriving anyclass (PIsDataRepr) + deriving + (PlutusType, PIsData) + via PIsDataReprInstances PStakeRedeemer -------------------------------------------------------------------------------- {- What this Policy does @@ -223,7 +221,7 @@ stakePolicy stake = foldr1 (#&&) [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' stake.gtClassRef.getAssetClass + , pgeqByClass' (untag stake.gtClassRef) # value # expectedValue , pgeqByClass @@ -300,15 +298,15 @@ stakeValidator stake = foldr1 (#&&) [ stakeDatum.owner #== newStakeDatum.owner - , (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount + , (stakeDatum.stakedAmount + delta) #== newStakeDatum.stakedAmount , -- We can't magically conjure GT anyway (no input to spend!) -- do we need to check this, really? - pgeqDiscrete # (pfromData newStakeDatum.stakedAmount) # pzeroDiscrete + zero #<= pfromData newStakeDatum.stakedAmount ] let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta) - ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # value) - ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # expectedValue) + ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # value) + ptrace (pshow $ passetClassValueOf' (untag stake.gtClassRef) # expectedValue) -- TODO: Same as above. This is quite inefficient now, as it does two lookups -- instead of a more efficient single pass, @@ -317,7 +315,7 @@ stakeValidator stake = foldr1 (#&&) [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue - , pgeqByClass' stake.gtClassRef.getAssetClass + , pgeqByClass' (untag stake.gtClassRef) # value # expectedValue , pgeqBySymbol diff --git a/flake.lock b/flake.lock index 89b8ae5..3f6d571 100644 --- a/flake.lock +++ b/flake.lock @@ -1381,11 +1381,11 @@ }, "nixpkgs-2111_3": { "locked": { - "lastModified": 1648420413, - "narHash": "sha256-AHejj7EsbTt+CMOoy15wwkFsFNmx8oinGgDZR22lS6g=", + "lastModified": 1648608655, + "narHash": "sha256-pTjZg9DwU89ZZ1fdtt6/i1X4vSNXoRJYUArgVZPh9F8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "d6778e0b5d608eb6738af2a64e26d99cdc5b9e86", + "rev": "ba93b1d8253ed4b359b9e81d10e02c106d3f8b11", "type": "github" }, "original": { @@ -1621,17 +1621,17 @@ "validity": "validity" }, "locked": { - "lastModified": 1648163186, - "narHash": "sha256-UfaSb4nk9HWzsj1Kb8RJuPV+iw1Nl4E2+97KOwIwcao=", + "lastModified": 1648639396, + "narHash": "sha256-pAkEsIDXJckVYufVPUzD/4sq4/uE7iyV0IR2BuLhZjY=", "owner": "peter-mlabs", "repo": "plutarch", - "rev": "0638dbd706bc2c5f48f9f40be7bbe1986a778698", + "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6", "type": "github" }, "original": { "owner": "peter-mlabs", - "ref": "liqwid/extra", "repo": "plutarch", + "rev": "a7a410da209b9c14c834a41e07b1c197c2a4dcd6", "type": "github" } }, diff --git a/flake.nix b/flake.nix index b944b18..abedaff 100644 --- a/flake.nix +++ b/flake.nix @@ -7,7 +7,9 @@ # see https://github.com/NixOS/nix/issues/6013 inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; }; - inputs.plutarch.url = "github:peter-mlabs/plutarch/liqwid/extra"; + # Rev is this PR https://github.com/peter-mlabs/plutarch/pull/5. + inputs.plutarch.url = + "github:peter-mlabs/plutarch?rev=a7a410da209b9c14c834a41e07b1c197c2a4dcd6"; inputs.plutarch.inputs.nixpkgs.follows = "plutarch/haskell-nix/nixpkgs-unstable"; @@ -56,8 +58,13 @@ extraSources = plutarch.extraSources ++ [ { src = inputs.plutarch; - subdirs = - [ "." "plutarch-test" "plutarch-extra" "plutarch-numeric" ]; + subdirs = [ + "." + "plutarch-test" + "plutarch-extra" + "plutarch-numeric" + "plutarch-safemoney" + ]; } { src = inputs.apropos-tx; @@ -96,6 +103,7 @@ ps.apropos-tx ps.plutarch-extra ps.plutarch-numeric + ps.plutarch-safemoney ps.plutarch-test ps.apropos ];