diff --git a/agora-specs/Property/Governor.hs b/agora-specs/Property/Governor.hs index 176773f..46bdc8b 100644 --- a/agora-specs/Property/Governor.hs +++ b/agora-specs/Property/Governor.hs @@ -7,232 +7,236 @@ Property model and tests for 'Governor' related functions -} module Property.Governor (props) where -import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid) -import Agora.Governor.Scripts (governorPolicy) -import Agora.Proposal ( - ProposalId (ProposalId), - ProposalThresholds (ProposalThresholds), - ) -import Agora.Proposal.Time ( - MaxTimeRangeWidth (MaxTimeRangeWidth), - ProposalTimingConfig (ProposalTimingConfig), - ) -import Data.Default.Class (Default (def)) -import Data.Tagged (Tagged (Tagged)) -import Data.Universe (Finite (..), Universe (..)) -import Plutarch.Api.V2 (PScriptContext) -import Plutarch.Builtin (pforgetData) -import Plutarch.Context ( - MintingBuilder, - buildMinting', - input, - mint, - output, - script, - withDatum, - withMinting, - withRef, - withValue, - ) -import Plutarch.Extra.AssetClass (assetClassValue) -import PlutusLedgerApi.V2 ( - ScriptContext (scriptContextTxInfo), - TxInInfo (txInInfoOutRef), - TxInfo (txInfoInputs, txInfoMint, txInfoOutputs), - TxOut (txOutValue), - ) -import Property.Generator (genInput, genOutput) -import Sample.Shared ( - governor, - governorAssetClass, - governorSymbol, - governorValidatorHash, - gstUTXORef, - ) +-- import Agora.Governor (Governor (gstOutRef), GovernorDatum (..), pisGovernorDatumValid) +-- import Agora.Governor.Scripts (governorPolicy) +-- import Agora.Proposal ( +-- ProposalId (ProposalId), +-- ProposalThresholds (ProposalThresholds), +-- ) +-- import Agora.Proposal.Time ( +-- MaxTimeRangeWidth (MaxTimeRangeWidth), +-- ProposalTimingConfig (ProposalTimingConfig), +-- ) +-- import Data.Default.Class (Default (def)) +-- import Data.Tagged (Tagged (Tagged)) +-- import Data.Universe (Finite (..), Universe (..)) +-- import Plutarch.Api.V2 (PScriptContext) +-- import Plutarch.Builtin (pforgetData) +-- import Plutarch.Context ( +-- MintingBuilder, +-- buildMinting', +-- input, +-- mint, +-- output, +-- script, +-- withDatum, +-- withMinting, +-- withRef, +-- withValue, +-- ) +-- import Plutarch.Extra.AssetClass (assetClassValue) +-- import PlutusLedgerApi.V2 ( +-- ScriptContext (scriptContextTxInfo), +-- TxInInfo (txInInfoOutRef), +-- TxInfo (txInfoInputs, txInfoMint, txInfoOutputs), +-- TxOut (txOutValue), +-- ) +-- import Property.Generator (genInput, genOutput) +-- import Sample.Shared ( +-- governor, +-- governorAssetClass, +-- governorSymbol, +-- governorValidatorHash, +-- gstUTXORef, +-- ) import Test.Tasty (TestTree) -import Test.Tasty.Plutarch.Property (classifiedPropertyNative) -import Test.Tasty.QuickCheck ( - Gen, - Property, - choose, - chooseInteger, - listOf1, - testProperty, - ) -data GovernorDatumCases - = ExecuteLE0 - | CreateLE0 - | ToVotingLE0 - | VoteLE0 - | CosignLE0 - | Correct - deriving stock (Eq, Show) +-- import Test.Tasty.Plutarch.Property (classifiedPropertyNative) +-- import Test.Tasty.QuickCheck ( +-- Gen, +-- Property, +-- choose, +-- chooseInteger, +-- listOf1, +-- testProperty, +-- ) -instance Universe GovernorDatumCases where - universe = - [ ExecuteLE0 - , CreateLE0 - , VoteLE0 - , CosignLE0 - , Correct - ] +-- data GovernorDatumCases +-- = ExecuteLE0 +-- | CreateLE0 +-- | ToVotingLE0 +-- | VoteLE0 +-- | CosignLE0 +-- | Correct +-- deriving stock (Eq, Show) -instance Finite GovernorDatumCases where - universeF = universe - cardinality = Tagged 6 +-- instance Universe GovernorDatumCases where +-- universe = +-- [ ExecuteLE0 +-- , CreateLE0 +-- , VoteLE0 +-- , CosignLE0 +-- , Correct +-- ] -{- | Property that checks `governorDatumValid`. - `governorDatumValid` determines if given governor datum is valid or not. This property - ensures `governorDatumValid` is checking the datum correctly and ruling out improper datum. --} -governorDatumValidProperty :: Property -governorDatumValidProperty = - classifiedPropertyNative gen (const []) expected classifier pisGovernorDatumValid - where - classifier :: GovernorDatum -> GovernorDatumCases - classifier - ( (.proposalThresholds) -> - ProposalThresholds - execute - create - toVoting - vote - cosign - ) - | execute < 0 = ExecuteLE0 - | create < 0 = CreateLE0 - | toVoting < 0 = ToVotingLE0 - | vote < 0 = VoteLE0 - | cosign < 0 = CosignLE0 - | otherwise = Correct +-- instance Finite GovernorDatumCases where +-- universeF = universe +-- cardinality = Tagged 6 - expected :: GovernorDatum -> Maybe Bool - expected c = Just $ classifier c == Correct +-- {- | Property that checks `governorDatumValid`. +-- `governorDatumValid` determines if given governor datum is valid or not. This property +-- ensures `governorDatumValid` is checking the datum correctly and ruling out improper datum. +-- -} +-- governorDatumValidProperty :: Property +-- governorDatumValidProperty = +-- classifiedPropertyNative gen (const []) expected classifier pisGovernorDatumValid +-- where +-- classifier :: GovernorDatum -> GovernorDatumCases +-- classifier +-- ( (.proposalThresholds) -> +-- ProposalThresholds +-- execute +-- create +-- toVoting +-- vote +-- cosign +-- ) +-- | execute < 0 = ExecuteLE0 +-- | create < 0 = CreateLE0 +-- | toVoting < 0 = ToVotingLE0 +-- | vote < 0 = VoteLE0 +-- | cosign < 0 = CosignLE0 +-- | otherwise = Correct - gen :: GovernorDatumCases -> Gen GovernorDatum - gen c = do - thres <- genProposalThresholds c +-- expected :: GovernorDatum -> Maybe Bool +-- expected c = Just $ classifier c == Correct - let timing = ProposalTimingConfig 0 0 0 0 - return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3 - where - taggedInteger p = Tagged <$> chooseInteger p - genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds - genProposalThresholds c = do - let validGT = taggedInteger (0, 1000000000) - execute <- validGT - create <- validGT - toVoting <- validGT - vote <- validGT - cosign <- validGT - le0 <- taggedInteger (-1000, -1) +-- gen :: GovernorDatumCases -> Gen GovernorDatum +-- gen c = do +-- thres <- genProposalThresholds c - case c of - ExecuteLE0 -> - -- execute < 0 - return $ ProposalThresholds le0 create toVoting vote cosign - CreateLE0 -> - -- c < 0 - return $ ProposalThresholds execute le0 toVoting vote cosign - ToVotingLE0 -> - return $ ProposalThresholds execute create le0 vote cosign - VoteLE0 -> - -- vote < 0 - return $ ProposalThresholds execute create toVoting le0 cosign - CosignLE0 -> - return $ ProposalThresholds execute create toVoting vote le0 - Correct -> - return $ ProposalThresholds execute create toVoting vote cosign +-- let timing = ProposalTimingConfig 0 0 0 0 +-- return $ GovernorDatum thres (ProposalId 0) timing (MaxTimeRangeWidth 1) 3 +-- where +-- taggedInteger p = Tagged <$> chooseInteger p +-- genProposalThresholds :: GovernorDatumCases -> Gen ProposalThresholds +-- genProposalThresholds c = do +-- let validGT = taggedInteger (0, 1000000000) +-- execute <- validGT +-- create <- validGT +-- toVoting <- validGT +-- vote <- validGT +-- cosign <- validGT +-- le0 <- taggedInteger (-1000, -1) -data GovernorPolicyCases - = ReferenceUTXONotSpent - | IncorrectAmountOfTokenMinted - | GovernorOutputNotFound - | GovernorPolicyCorrect - deriving stock (Eq, Show) +-- case c of +-- ExecuteLE0 -> +-- -- execute < 0 +-- return $ ProposalThresholds le0 create toVoting vote cosign +-- CreateLE0 -> +-- -- c < 0 +-- return $ ProposalThresholds execute le0 toVoting vote cosign +-- ToVotingLE0 -> +-- return $ ProposalThresholds execute create le0 vote cosign +-- VoteLE0 -> +-- -- vote < 0 +-- return $ ProposalThresholds execute create toVoting le0 cosign +-- CosignLE0 -> +-- return $ ProposalThresholds execute create toVoting vote le0 +-- Correct -> +-- return $ ProposalThresholds execute create toVoting vote cosign -instance Universe GovernorPolicyCases where - universe = - [ ReferenceUTXONotSpent - , IncorrectAmountOfTokenMinted - , GovernorOutputNotFound - , GovernorPolicyCorrect - ] +-- data GovernorPolicyCases +-- = ReferenceUTXONotSpent +-- | IncorrectAmountOfTokenMinted +-- | GovernorOutputNotFound +-- | GovernorPolicyCorrect +-- deriving stock (Eq, Show) -instance Finite GovernorPolicyCases where - universeF = universe - cardinality = Tagged 4 +-- instance Universe GovernorPolicyCases where +-- universe = +-- [ ReferenceUTXONotSpent +-- , IncorrectAmountOfTokenMinted +-- , GovernorOutputNotFound +-- , GovernorPolicyCorrect +-- ] -governorMintingProperty :: Property -governorMintingProperty = - classifiedPropertyNative gen (const []) expected classifier actual - where - {- Note: - I don't think it's easily possible to randomize orefs. We can't really pass pass `Governor` type to `actual` function. - -} - gst = assetClassValue governorAssetClass 1 - mintAmount x = mint . mconcat $ replicate x gst - outputToGov = - output $ - mconcat - [ script governorValidatorHash - , withValue gst - , withDatum govDatum - ] - referencedInput = input $ withRef gstUTXORef +-- instance Finite GovernorPolicyCases where +-- universeF = universe +-- cardinality = Tagged 4 - govDatum :: GovernorDatum - govDatum = - GovernorDatum - { proposalThresholds = def - , nextProposalId = ProposalId 0 - , proposalTimings = def - , createProposalTimeRangeMaxWidth = def - , maximumProposalsPerStake = 3 - } +-- governorMintingProperty :: Property +-- governorMintingProperty = +-- classifiedPropertyNative gen (const []) expected classifier actual +-- where +-- {- Note: +-- I don't think it's easily possible to randomize orefs. We can't really pass pass `Governor` type to `actual` function. +-- -} +-- gst = assetClassValue governorAssetClass 1 +-- mintAmount x = mint . mconcat $ replicate x gst +-- outputToGov = +-- output $ +-- mconcat +-- [ script governorValidatorHash +-- , withValue gst +-- , withDatum govDatum +-- ] +-- referencedInput = input $ withRef gstUTXORef - gen :: GovernorPolicyCases -> Gen ScriptContext - gen c = do - inputs <- fmap mconcat . listOf1 $ genInput @MintingBuilder - outputs <- fmap mconcat . listOf1 $ genOutput @MintingBuilder - toks <- choose (2, 100) +-- govDatum :: GovernorDatum +-- govDatum = +-- GovernorDatum +-- { proposalThresholds = def +-- , nextProposalId = ProposalId 0 +-- , proposalTimings = def +-- , createProposalTimeRangeMaxWidth = def +-- , maximumProposalsPerStake = 3 +-- } - let comp = - case c of - ReferenceUTXONotSpent -> outputToGov <> mintAmount 1 - IncorrectAmountOfTokenMinted -> referencedInput <> outputToGov <> mintAmount toks - GovernorOutputNotFound -> referencedInput <> mintAmount 1 - GovernorPolicyCorrect -> referencedInput <> outputToGov <> mintAmount 1 +-- gen :: GovernorPolicyCases -> Gen ScriptContext +-- gen c = do +-- inputs <- fmap mconcat . listOf1 $ genInput @MintingBuilder +-- outputs <- fmap mconcat . listOf1 $ genOutput @MintingBuilder +-- toks <- choose (2, 100) - return . buildMinting' $ inputs <> outputs <> comp <> withMinting governorSymbol +-- let comp = +-- case c of +-- ReferenceUTXONotSpent -> outputToGov <> mintAmount 1 +-- IncorrectAmountOfTokenMinted -> referencedInput <> outputToGov <> mintAmount toks +-- GovernorOutputNotFound -> referencedInput <> mintAmount 1 +-- GovernorPolicyCorrect -> referencedInput <> outputToGov <> mintAmount 1 - expected :: ScriptContext -> Maybe () - expected sc = - case classifier sc of - GovernorPolicyCorrect -> Just () - _ -> Nothing +-- return . buildMinting' $ inputs <> outputs <> comp <> withMinting governorSymbol - opaqueToUnit :: Term s (POpaque :--> PUnit) - opaqueToUnit = plam $ \_ -> pconstant () +-- expected :: ScriptContext -> Maybe () +-- expected sc = +-- case classifier sc of +-- GovernorPolicyCorrect -> Just () +-- _ -> Nothing - actual :: Term s (PScriptContext :--> PUnit) - actual = plam $ \sc -> opaqueToUnit #$ governorPolicy # pconstant governor.gstOutRef # pforgetData (pconstantData ()) # sc +-- opaqueToUnit :: Term s (POpaque :--> PUnit) +-- opaqueToUnit = plam $ \_ -> pconstant () - classifier :: ScriptContext -> GovernorPolicyCases - classifier sc - | minted /= gst = IncorrectAmountOfTokenMinted - | refInputNotExists = ReferenceUTXONotSpent - | govOutputNotExists = GovernorOutputNotFound - | otherwise = GovernorPolicyCorrect - where - txinfo = scriptContextTxInfo sc - minted = txInfoMint txinfo - refInputNotExists = gstUTXORef `notElem` (txInInfoOutRef <$> txInfoInputs txinfo) - govOutputNotExists = gst `notElem` (txOutValue <$> txInfoOutputs txinfo) +-- actual :: Term s (PScriptContext :--> PUnit) +-- actual = plam $ \sc -> opaqueToUnit #$ governorPolicy # pconstant governor.gstOutRef # pforgetData (pconstantData ()) # sc + +-- classifier :: ScriptContext -> GovernorPolicyCases +-- classifier sc +-- | minted /= gst = IncorrectAmountOfTokenMinted +-- | refInputNotExists = ReferenceUTXONotSpent +-- | govOutputNotExists = GovernorOutputNotFound +-- | otherwise = GovernorPolicyCorrect +-- where +-- txinfo = scriptContextTxInfo sc +-- minted = txInfoMint txinfo +-- refInputNotExists = gstUTXORef `notElem` (txInInfoOutRef <$> txInfoInputs txinfo) +-- govOutputNotExists = gst `notElem` (txOutValue <$> txInfoOutputs txinfo) + +-- props :: [TestTree] +-- props = +-- [ testProperty "governorDatumValid" governorDatumValidProperty +-- , testProperty "governorPolicy" governorMintingProperty +-- ] props :: [TestTree] -props = - [ testProperty "governorDatumValid" governorDatumValidProperty - , testProperty "governorPolicy" governorMintingProperty - ] +props = [] diff --git a/agora-specs/Sample/AuthorityToken/UnauthorizedMintingExploit.hs b/agora-specs/Sample/AuthorityToken/UnauthorizedMintingExploit.hs index 62416e3..27791bc 100644 --- a/agora-specs/Sample/AuthorityToken/UnauthorizedMintingExploit.hs +++ b/agora-specs/Sample/AuthorityToken/UnauthorizedMintingExploit.hs @@ -4,9 +4,9 @@ module Sample.AuthorityToken.UnauthorizedMintingExploit ( mkTestCase, ) where -import Agora.Utils (validatorHashToTokenName) import Control.Exception (assert) import Plutarch.Context (input, mint, normalizeValue, output, script, withValue) +import Plutarch.Extra.ScriptContext (validatorHashToTokenName) import PlutusLedgerApi.V1.Value qualified as Value import Sample.Shared (authorityTokenPolicy, authorityTokenSymbol, minAda) import Test.Specification (SpecificationTree, testPolicy) diff --git a/agora-specs/Sample/Effect/GovernorMutation.hs b/agora-specs/Sample/Effect/GovernorMutation.hs index 21a88b6..7739d80 100644 --- a/agora-specs/Sample/Effect/GovernorMutation.hs +++ b/agora-specs/Sample/Effect/GovernorMutation.hs @@ -17,12 +17,12 @@ import Agora.Effect.GovernorMutation ( import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor)) import Agora.Proposal (ProposalId (..), ProposalThresholds (..)) import Agora.SafeMoney (AuthorityTokenTag) -import Agora.Utils (validatorHashToTokenName) import Data.Default.Class (Default (def)) import Data.Map ((!)) import Data.Tagged (Tagged (..)) import Plutarch.Api.V2 (validatorHash) import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue) +import Plutarch.Extra.ScriptContext (validatorHashToTokenName) import PlutusLedgerApi.V1 qualified as Interval (always) import PlutusLedgerApi.V1.Address (scriptHashAddress) import PlutusLedgerApi.V1.Value qualified as Value ( diff --git a/agora-specs/Sample/Governor/Mutate.hs b/agora-specs/Sample/Governor/Mutate.hs index 029a030..a2ca582 100644 --- a/agora-specs/Sample/Governor/Mutate.hs +++ b/agora-specs/Sample/Governor/Mutate.hs @@ -18,7 +18,6 @@ module Sample.Governor.Mutate ( import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor)) import Agora.Proposal (ProposalId (ProposalId), ProposalThresholds (..)) -import Agora.Utils (scriptHashToTokenName) import Data.Default (def) import Data.Map ((!)) import Plutarch.Api.V2 (PMintingPolicy, mintingPolicySymbol, mkMintingPolicy, validatorHash) @@ -33,6 +32,7 @@ import Plutarch.Context ( withValue, ) import Plutarch.Extra.AssetClass (assetClassValue) +import Plutarch.Extra.ScriptContext (scriptHashToTokenName) import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V2 ( CurrencySymbol (CurrencySymbol), diff --git a/agora-specs/Sample/Proposal/Advance.hs b/agora-specs/Sample/Proposal/Advance.hs index c06fd38..1b5baab 100644 --- a/agora-specs/Sample/Proposal/Advance.hs +++ b/agora-specs/Sample/Proposal/Advance.hs @@ -68,7 +68,6 @@ import Agora.SafeMoney (AuthorityTokenTag, GTTag) import Agora.Stake ( StakeDatum (..), ) -import Agora.Utils (scriptHashToTokenName) import Control.Applicative (liftA2) import Control.Monad.State (execState, modify, when) import Data.Default (def) @@ -90,6 +89,7 @@ import Plutarch.Context ( withValue, ) import Plutarch.Extra.AssetClass (AssetClass (AssetClass), assetClassValue) +import Plutarch.Extra.ScriptContext (scriptHashToTokenName) import Plutarch.Lift (PLifted, PUnsafeLiftDecl) import PlutusLedgerApi.V2 ( Credential (PubKeyCredential), diff --git a/agora-specs/Sample/Proposal/Create.hs b/agora-specs/Sample/Proposal/Create.hs index f61fd2b..1ce4ab5 100644 --- a/agora-specs/Sample/Proposal/Create.hs +++ b/agora-specs/Sample/Proposal/Create.hs @@ -46,7 +46,6 @@ import Agora.Stake ( StakeDatum (..), StakeRedeemer (PermitVote), ) -import Agora.Utils (validatorHashToTokenName) import Data.Coerce (coerce) import Data.Default (Default (def)) import Data.Map.Strict qualified as StrictMap @@ -66,6 +65,7 @@ import Plutarch.Context ( withValue, ) import Plutarch.Extra.AssetClass (assetClassValue) +import Plutarch.Extra.ScriptContext (validatorHashToTokenName) import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V2 ( Credential (PubKeyCredential), diff --git a/agora-specs/Sample/Proposal/Unlock.hs b/agora-specs/Sample/Proposal/Unlock.hs index 8b3e380..9186952 100644 --- a/agora-specs/Sample/Proposal/Unlock.hs +++ b/agora-specs/Sample/Proposal/Unlock.hs @@ -49,7 +49,6 @@ import Agora.Stake ( StakeDatum (..), StakeRedeemer (RetractVotes), ) -import Agora.Utils (validatorHashToTokenName) import Data.Default.Class (Default (def)) import Data.Map.Strict qualified as StrictMap import Data.Tagged (Tagged, untag) @@ -67,6 +66,7 @@ import Plutarch.Context ( withValue, ) import Plutarch.Extra.AssetClass (assetClassValue) +import Plutarch.Extra.ScriptContext (validatorHashToTokenName) import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V2 ( Credential (PubKeyCredential), diff --git a/agora-specs/Sample/Shared.hs b/agora-specs/Sample/Shared.hs index b2ac27f..397f9e2 100644 --- a/agora-specs/Sample/Shared.hs +++ b/agora-specs/Sample/Shared.hs @@ -72,9 +72,6 @@ import Agora.Proposal.Time ( ProposalTimingConfig (..), ) import Agora.SafeMoney (GovernorSTTag, ProposalSTTag, StakeSTTag) -import Agora.Utils ( - validatorHashToTokenName, - ) import Data.Default.Class (Default (..)) import Data.Map (Map, (!)) import Data.Tagged (Tagged (..)) @@ -86,6 +83,7 @@ import Plutarch.Api.V2 ( validatorHash, ) import Plutarch.Extra.AssetClass (AssetClass (AssetClass)) +import Plutarch.Extra.ScriptContext (validatorHashToTokenName) import PlutusLedgerApi.V1.Address (scriptHashAddress) import PlutusLedgerApi.V1.Value (TokenName, Value) import PlutusLedgerApi.V1.Value qualified as Value ( diff --git a/agora-specs/Sample/Stake/Create.hs b/agora-specs/Sample/Stake/Create.hs index 40266df..38f13f7 100644 --- a/agora-specs/Sample/Stake/Create.hs +++ b/agora-specs/Sample/Stake/Create.hs @@ -21,7 +21,6 @@ import Agora.Governor (Governor (gtClassRef)) import Agora.Proposal (ProposalId (ProposalId)) import Agora.SafeMoney (GTTag) import Agora.Stake (ProposalLock (Created), StakeDatum (..)) -import Agora.Utils (validatorHashToTokenName) import Data.Semigroup (stimesMonoid) import Data.Tagged (Tagged) import Plutarch.Context ( @@ -36,6 +35,7 @@ import Plutarch.Context ( withValue, ) import Plutarch.Extra.AssetClass (assetClassValue) +import Plutarch.Extra.ScriptContext (validatorHashToTokenName) import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) import PlutusLedgerApi.V1.Value qualified as Value import PlutusLedgerApi.V2 ( diff --git a/agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs b/agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs index 4523713..88dd673 100644 --- a/agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs +++ b/agora-specs/Sample/Stake/UnauthorizedMintingExploit.hs @@ -4,7 +4,6 @@ module Sample.Stake.UnauthorizedMintingExploit ( mkTestCase, ) where -import Agora.Utils (validatorHashToTokenName) import Plutarch.Context ( input, mint, @@ -14,6 +13,7 @@ import Plutarch.Context ( withValue, ) import Plutarch.Extra.AssetClass (assetClassValue) +import Plutarch.Extra.ScriptContext (validatorHashToTokenName) import PlutusLedgerApi.V1.Value qualified as Value import Sample.Shared ( minAda, diff --git a/agora/Agora/AuthorityToken.hs b/agora/Agora/AuthorityToken.hs index aeefa4a..0ade9ab 100644 --- a/agora/Agora/AuthorityToken.hs +++ b/agora/Agora/AuthorityToken.hs @@ -11,10 +11,6 @@ module Agora.AuthorityToken ( singleAuthorityTokenBurned, ) where -import Agora.Utils ( - passert, - psymbolValueOf', - ) import Plutarch.Api.V1 ( PCredential (..), PCurrencySymbol (..), @@ -33,6 +29,7 @@ import Plutarch.Api.V2 ( PTxOut (PTxOut), ) import Plutarch.Extra.AssetClass (PAssetClassData, ptoScottEncoding) +import Plutarch.Extra.Bool (passert) import "liqwid-plutarch-extra" Plutarch.Extra.List (plookupAssoc) import Plutarch.Extra.Maybe (pfromJust) import Plutarch.Extra.ScriptContext (pisTokenSpent) @@ -44,7 +41,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont ( pmatchC, ) import Plutarch.Extra.Traversable (pfoldMap) -import Plutarch.Extra.Value (psymbolValueOf) +import Plutarch.Extra.Value (psymbolValueOf, psymbolValueOf') -------------------------------------------------------------------------------- diff --git a/agora/Agora/Effect/GovernorMutation.hs b/agora/Agora/Effect/GovernorMutation.hs index 1b10ee7..fc72cf2 100644 --- a/agora/Agora/Effect/GovernorMutation.hs +++ b/agora/Agora/Effect/GovernorMutation.hs @@ -26,7 +26,6 @@ import Agora.Governor ( PGovernorRedeemer, ) import Agora.Plutarch.Orphans () -import Agora.Utils (pfromSingleton, ptryFromRedeemer) import Plutarch.Api.V1 (PCurrencySymbol, PValidatorHash) import Plutarch.Api.V2 ( PScriptPurpose (PSpending), @@ -38,9 +37,15 @@ import Plutarch.DataRepr ( PDataFields, ) import Plutarch.Extra.Field (pletAll, pletAllC) +import "liqwid-plutarch-extra" Plutarch.Extra.List (ptryFromSingleton) import Plutarch.Extra.Maybe (passertPJust, pdnothing) import Plutarch.Extra.Record (mkRecordConstr, (.=)) -import Plutarch.Extra.ScriptContext (paddressFromValidatorHash, pfromOutputDatum, pisScriptAddress) +import Plutarch.Extra.ScriptContext ( + paddressFromValidatorHash, + pisScriptAddress, + ptryFromOutputDatum, + ptryFromRedeemer, + ) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC) import Plutarch.Extra.Value (psymbolValueOf) import Plutarch.Lift (PConstantDecl, PLifted, PUnsafeLiftDecl) @@ -216,11 +221,11 @@ mutateGovernorValidator = let governorOutput = ptrace "Only governor output is allowed" $ - pfromSingleton # pfromData txInfoF.outputs + ptryFromSingleton # pfromData txInfoF.outputs governorOutputDatum = ptrace "Resolve governor outoput datum" $ - pfromOutputDatum @PGovernorDatum + ptryFromOutputDatum @PGovernorDatum # (pfield @"datum" # governorOutput) # txInfoF.datums diff --git a/agora/Agora/Effect/TreasuryWithdrawal.hs b/agora/Agora/Effect/TreasuryWithdrawal.hs index 9501b19..879e078 100644 --- a/agora/Agora/Effect/TreasuryWithdrawal.hs +++ b/agora/Agora/Effect/TreasuryWithdrawal.hs @@ -15,7 +15,6 @@ module Agora.Effect.TreasuryWithdrawal ( import Agora.Effect (makeEffect) import Agora.Plutarch.Orphans () -import Agora.Utils (pdelete) import Plutarch.Api.V1 ( PCredential, PCurrencySymbol, @@ -35,6 +34,7 @@ import Plutarch.DataRepr ( PDataFields, ) import Plutarch.Extra.Field (pletAllC) +import "liqwid-plutarch-extra" Plutarch.Extra.List (pdeleteFirst) import Plutarch.Extra.ScriptContext (pisPubKey) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pletFieldsC) import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted)) @@ -178,7 +178,7 @@ treasuryWithdrawalValidator = plam $ (ptraceError "Invalid receiver") pure $ - pmatch (pdelete # credValue # receivers) $ \case + pmatch (pdeleteFirst # credValue # receivers) $ \case PJust updatedReceivers -> ptrace "Receiver output" updatedReceivers PNothing -> diff --git a/agora/Agora/Governor/Scripts.hs b/agora/Agora/Governor/Scripts.hs index 1c09ae1..f80a86a 100644 --- a/agora/Agora/Governor/Scripts.hs +++ b/agora/Agora/Governor/Scripts.hs @@ -40,10 +40,6 @@ import Agora.Stake ( pnumCreatedProposals, presolveStakeInputDatum, ) -import Agora.Utils ( - plistEqualsBy, - pscriptHashToTokenName, - ) import Plutarch.Api.V1 (PCurrencySymbol) import Plutarch.Api.V1.AssocMap (plookup) import Plutarch.Api.V1.AssocMap qualified as AssocMap @@ -57,17 +53,18 @@ import Plutarch.Api.V2 ( ) import Plutarch.Extra.AssetClass (PAssetClassData, passetClass, ptoScottEncoding) import Plutarch.Extra.Field (pletAll, pletAllC) -import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe) +import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, plistEqualsBy, pmapMaybe) import "liqwid-plutarch-extra" Plutarch.Extra.Map (pkeys, ptryLookup) import Plutarch.Extra.Maybe (passertPJust, pjust, pmaybe, pmaybeData, pnothing) import Plutarch.Extra.Ord (psort) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.ScriptContext ( pfindTxInByTxOutRef, - pfromDatumHash, - pfromOutputDatum, pisUTXOSpent, pscriptHashFromAddress, + pscriptHashToTokenName, + ptryFromDatumHash, + ptryFromOutputDatum, pvalueSpent, ) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont ( @@ -153,7 +150,7 @@ governorPolicy = governorDatum = ptrace "Resolve governor datum" $ - pfromOutputDatum @PGovernorDatum + ptryFromOutputDatum @PGovernorDatum # txOutF.datum # txInfoF.datums in pif isGovernorUTxO (pjust # governorDatum) pnothing @@ -323,7 +320,7 @@ governorValidator = datum = ptrace "Resolve governor datum" $ - pfromOutputDatum @PGovernorDatum + ptryFromOutputDatum @PGovernorDatum # outputF.datum # txInfoF.datums in pif @@ -350,7 +347,7 @@ governorValidator = proposalDatum = ptrace "Resolve proposal output datum" $ pfromData $ - pfromOutputDatum + ptryFromOutputDatum # txOutF.datum # txInfoF.datums in pif isProposalUTxO (pjust # proposalDatum) pnothing @@ -546,7 +543,7 @@ governorValidator = #== 1 let hasCorrectDatum = - effect.datumHash #== pfromDatumHash # outputF.datum + effect.datumHash #== ptryFromDatumHash # outputF.datum pguardC "Authority output valid" $ foldr1 @@ -568,7 +565,7 @@ governorValidator = -- The sorted hashes of all the GAT receivers. actualReceivers = psort - #$ pmapMaybe + #$ pmapMaybe @PList # getReceiverScriptHash # pfromData txInfoF.outputs diff --git a/agora/Agora/Linker.hs b/agora/Agora/Linker.hs index 1db1a43..956dfe1 100644 --- a/agora/Agora/Linker.hs +++ b/agora/Agora/Linker.hs @@ -3,12 +3,13 @@ module Agora.Linker (linker, AgoraScriptInfo (..)) where import Agora.Governor (Governor (gstOutRef, gtClassRef, maximumCosigners)) -import Agora.Utils (validatorHashToAddress, validatorHashToTokenName) +import Agora.Utils (validatorHashToAddress) import Data.Aeson qualified as Aeson import Data.Map (fromList) import Data.Tagged (untag) import Plutarch.Api.V2 (mintingPolicySymbol, validatorHash) import Plutarch.Extra.AssetClass (AssetClass (AssetClass)) +import Plutarch.Extra.ScriptContext (validatorHashToTokenName) import PlutusLedgerApi.V1 (Address, CurrencySymbol, TxOutRef, ValidatorHash) import Ply ( ScriptRole (MintingPolicyRole, ValidatorRole), diff --git a/agora/Agora/Proposal/Scripts.hs b/agora/Agora/Proposal/Scripts.hs index 944112d..3cc3f0a 100644 --- a/agora/Agora/Proposal/Scripts.hs +++ b/agora/Agora/Proposal/Scripts.hs @@ -35,13 +35,6 @@ import Agora.Stake ( pisVoter, presolveStakeInputDatum, ) -import Agora.Utils ( - pfromSingleton, - pinsertUniqueBy, - plistEqualsBy, - pmapMaybe, - ptryFromRedeemer, - ) import Plutarch.Api.V1 (PCredential, PCurrencySymbol) import Plutarch.Api.V1.AssocMap (plookup) import Plutarch.Api.V2 ( @@ -56,7 +49,12 @@ import Plutarch.Extra.AssetClass ( ) import Plutarch.Extra.Category (PCategory (pidentity)) import Plutarch.Extra.Field (pletAll, pletAllC) -import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust) +import "liqwid-plutarch-extra" Plutarch.Extra.List ( + pfindJust, + plistEqualsBy, + pmapMaybe, + ptryFromSingleton, + ) import "plutarch-extra" Plutarch.Extra.Map (pupdate) import Plutarch.Extra.Maybe ( passertPJust, @@ -66,11 +64,12 @@ import Plutarch.Extra.Maybe ( pmaybe, pnothing, ) -import Plutarch.Extra.Ord (pfromOrdBy, psort) +import Plutarch.Extra.Ord (pfromOrdBy, pinsertUniqueBy, psort) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import Plutarch.Extra.ScriptContext ( pfindTxInByTxOutRef, - pfromOutputDatum, + ptryFromOutputDatum, + ptryFromRedeemer, ) import Plutarch.Extra.Sum (PSum (PSum)) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont ( @@ -309,7 +308,7 @@ proposalValidator = -- Using inline datum to avoid O(n^2) lookup. pfromData $ ptrace "Resolve proposal datum" $ - pfromOutputDatum @(PAsData PProposalDatum) + ptryFromOutputDatum @(PAsData PProposalDatum) # outputF.datum # txInfoF.datums in pif @@ -348,7 +347,7 @@ proposalValidator = pletC $ plam $ let stakeInputs = - pmapMaybe + pmapMaybe @PList # resolveStakeInputDatum # pfromData txInfoF.inputs @@ -439,7 +438,7 @@ proposalValidator = stakeF <- pletFieldsC @'["owner", "stakedAmount"] $ ptrace "Exactly one stake input" $ - pfromSingleton # sctxF.inputStakes + ptryFromSingleton # sctxF.inputStakes let newCosigner = stakeF.owner diff --git a/agora/Agora/Proposal/Time.hs b/agora/Agora/Proposal/Time.hs index 2b14fb1..892b10f 100644 --- a/agora/Agora/Proposal/Time.hs +++ b/agora/Agora/Proposal/Time.hs @@ -30,7 +30,6 @@ module Agora.Proposal.Time ( pisWithin, ) where -import Agora.Utils (pcurrentTimeDuration) import Control.Composition ((.*)) import Data.Functor ((<&>)) import Plutarch.Api.V1 ( @@ -52,6 +51,7 @@ import Plutarch.Extra.Maybe (pjust, pmaybe, pnothing) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pletC, pmatchC) import Plutarch.Extra.Time ( PCurrentTime (PCurrentTime), + pcurrentTimeDuration, pisWithinCurrentTime, ) import Plutarch.Lift ( diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 671f1f9..f35e4d5 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -50,7 +50,6 @@ import Agora.Proposal ( ResultTag, ) import Agora.SafeMoney (GTTag) -import Agora.Utils (pmapMaybe, ppureIf) import Data.Tagged (Tagged) import Generics.SOP qualified as SOP import Plutarch.Api.V1 (PCredential) @@ -67,15 +66,16 @@ import Plutarch.DataRepr ( DerivePConstantViaData (DerivePConstantViaData), PDataFields, ) +import Plutarch.Extra.Applicative (ppureIf) import Plutarch.Extra.AssetClass (PAssetClass) import Plutarch.Extra.Field (pletAll) import Plutarch.Extra.IsData ( DerivePConstantViaDataList (DerivePConstantViaDataList), ProductIsData (ProductIsData), ) -import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust) +import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe) import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing) -import Plutarch.Extra.ScriptContext (pfromOutputDatum) +import Plutarch.Extra.ScriptContext (ptryFromOutputDatum) import Plutarch.Extra.Sum (PSum (PSum)) import Plutarch.Extra.Tagged (PTagged) import Plutarch.Extra.Traversable (pfoldMap) @@ -734,7 +734,7 @@ presolveStakeInputDatum = phoistAcyclic $ datum = ptrace "Resolve stake datum" $ pfromData $ - pfromOutputDatum @(PAsData PStakeDatum) + ptryFromOutputDatum @(PAsData PStakeDatum) # txOutF.datum # datums in pif diff --git a/agora/Agora/Stake/Redeemers.hs b/agora/Agora/Stake/Redeemers.hs index e829221..40f9b11 100644 --- a/agora/Agora/Stake/Redeemers.hs +++ b/agora/Agora/Stake/Redeemers.hs @@ -48,10 +48,10 @@ import Agora.Stake ( ), pstakeLocked, ) -import Agora.Utils (pfromSingleton, pisSingleton, pmustDeleteBy) import Plutarch.Api.V1.Address (PCredential) import Plutarch.Api.V2 (PMaybeData) import Plutarch.Extra.Field (pletAll, pletAllC) +import "liqwid-plutarch-extra" Plutarch.Extra.List (pisSingleton, ptryDeleteFirstBy, ptryFromSingleton) import Plutarch.Extra.Maybe (pdjust, pdnothing, pmaybeData) import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=)) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (pguardC, pletC, pmatchC) @@ -87,7 +87,7 @@ pbatchUpdateInputs = phoistAcyclic $ plam $ \f -> flip pmatch $ \ctxF -> pnull #$ pfoldr - # (pmustDeleteBy # f) + # plam (\x -> ptryDeleteFirstBy # (f # x)) # ctxF.stakeOutputDatums # ctxF.stakeInputDatums @@ -387,12 +387,12 @@ pdepositWithdraw = phoistAcyclic $ stakeInputDatum <- pletC $ ptrace "Single stake input" $ - pfromSingleton # ctxF.stakeInputDatums + ptryFromSingleton # ctxF.stakeInputDatums stakeInputDatumF <- pletAllC stakeInputDatum let stakeOutputDatum = ptrace "Single stake output" $ - pfromSingleton # ctxF.stakeOutputDatums + ptryFromSingleton # ctxF.stakeOutputDatums ---------------------------------------------------------------------------- diff --git a/agora/Agora/Stake/Scripts.hs b/agora/Agora/Stake/Scripts.hs index c3ab8bf..bb25b29 100644 --- a/agora/Agora/Stake/Scripts.hs +++ b/agora/Agora/Stake/Scripts.hs @@ -52,13 +52,7 @@ import Agora.Stake.Redeemers ( ppermitVote, pretractVote, ) -import Agora.Utils ( - passert, - pisDNothing, - pmapMaybe, - psymbolValueOf', - pvalidatorHashToTokenName, - ) +import Agora.Utils (pisDNothing) import Plutarch.Api.V1 ( PCredential (PPubKeyCredential, PScriptCredential), PCurrencySymbol, @@ -79,9 +73,10 @@ import Plutarch.Extra.AssetClass ( passetClass, ptoScottEncoding, ) +import Plutarch.Extra.Bool (passert) import Plutarch.Extra.Field (pletAll, pletAllC) import Plutarch.Extra.Functor (PFunctor (pfmap)) -import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust) +import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe) import Plutarch.Extra.Maybe ( passertPJust, pfromJust, @@ -93,7 +88,8 @@ import Plutarch.Extra.Maybe ( import Plutarch.Extra.Ord (POrdering (PEQ, PGT, PLT), pcompareBy, pfromOrd) import Plutarch.Extra.ScriptContext ( pfindTxInByTxOutRef, - pfromOutputDatum, + ptryFromOutputDatum, + pvalidatorHashToTokenName, pvalueSpent, ) import "liqwid-plutarch-extra" Plutarch.Extra.TermCont ( @@ -106,6 +102,7 @@ import "liqwid-plutarch-extra" Plutarch.Extra.TermCont ( import Plutarch.Extra.Value ( passetClassValueOf, psymbolValueOf, + psymbolValueOf', ) import Plutarch.Num (PNum (pnegate)) import Plutarch.Unsafe (punsafeCoerce) @@ -197,7 +194,7 @@ stakePolicy = datumF <- pletAllC $ pfromData $ - pfromOutputDatum @(PAsData PStakeDatum) + ptryFromOutputDatum @(PAsData PStakeDatum) # outputF.datum # txInfoF.datums @@ -277,10 +274,11 @@ mkStakeValidator impl sstSymbol pstClass gstClass = #$ pfield @"address" # validatedInput - let sstName = pvalidatorHashToTokenName #$ pmatch stakeValidatorCredential $ - \case - PScriptCredential r -> pfield @"_0" # r - _ -> perror + let sstName = pvalidatorHashToTokenName $ + pmatch stakeValidatorCredential $ + \case + PScriptCredential r -> pfield @"_0" # r + _ -> perror sstClass <- pletC $ passetClass # sstSymbol # sstName @@ -310,7 +308,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass = datum = ptrace "Resolve stake datum" $ pfromData $ - pfromOutputDatum @(PAsData PStakeDatum) + ptryFromOutputDatum @(PAsData PStakeDatum) # txOutF.datum # txInfoF.datums in passert @@ -439,7 +437,7 @@ mkStakeValidator impl sstSymbol pstClass gstClass = #== 1 proposalDatum = pfromData $ - pfromOutputDatum @(PAsData PProposalDatum) + ptryFromOutputDatum @(PAsData PProposalDatum) # txOutF.datum # txInfoF.datums in pif isProposalUTxO (pjust # proposalDatum) pnothing diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 8288ea1..c7504e4 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -8,101 +8,22 @@ Description: Plutarch utility functions that should be upstreamed or don't belon Plutarch utility functions that should be upstreamed or don't belong anywhere else. -} module Agora.Utils ( - validatorHashToTokenName, validatorHashToAddress, - pltAsData, - withBuiltinPairAsData, - pvalidatorHashToTokenName, - pscriptHashToTokenName, - scriptHashToTokenName, - plistEqualsBy, pstringIntercalate, punwords, - pcurrentTimeDuration, - pdelete, - pdeleteBy, - pmustDeleteBy, - pisSingleton, - pfromSingleton, - pmapMaybe, - PAlternative (..), - ppureIf, - pltBy, - pinsertUniqueBy, - ptryFromRedeemer, - passert, pisNothing, pisDNothing, - psymbolValueOf', ) where -import Plutarch.Api.V1 ( - KeyGuarantees (Unsorted), - PPOSIXTime, - PRedeemer, - PValidatorHash, - ) -import Plutarch.Api.V1.AssocMap (PMap, plookup) import Plutarch.Api.V2 ( - AmountGuarantees, - PCurrencySymbol, PMaybeData (PDNothing), - PScriptHash, - PScriptPurpose, - PTokenName, - PValue, ) -import Plutarch.Extra.Applicative (PApplicative (ppure)) -import Plutarch.Extra.Category (PCategory (pidentity)) -import Plutarch.Extra.Functor (PFunctor (PSubcategory, pfmap)) -import Plutarch.Extra.Maybe (pjust, pnothing) -import Plutarch.Extra.Ord (PComparator, POrdering (PLT), pcompareBy, pequateBy) -import Plutarch.Extra.Time (PCurrentTime (PCurrentTime)) -import Plutarch.Unsafe (punsafeCoerce) import PlutusLedgerApi.V2 ( Address (Address), Credential (ScriptCredential), - ScriptHash (ScriptHash), - TokenName (TokenName), - ValidatorHash (ValidatorHash), + ValidatorHash, ) -{- Functions which should (probably) not be upstreamed - All of these functions are quite inefficient. --} - -{- | Safely convert a 'ValidatorHash' into a 'TokenName'. This can be useful for tagging - tokens for extra safety. - - @since 0.1.0 --} -validatorHashToTokenName :: ValidatorHash -> TokenName -validatorHashToTokenName (ValidatorHash hash) = TokenName hash - -{- | Safely convert a 'PValidatorHash' into a 'PTokenName'. This can be useful for tagging - tokens for extra safety. - - @since 1.0.0 --} -pvalidatorHashToTokenName :: forall (s :: S). Term s (PValidatorHash :--> PTokenName) -pvalidatorHashToTokenName = phoistAcyclic $ plam punsafeCoerce - -{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging - tokens for extra safety. - - @since 1.0.0 --} -scriptHashToTokenName :: ScriptHash -> TokenName -scriptHashToTokenName (ScriptHash hash) = TokenName hash - -{- | Safely convert a 'PScriptHash' into a 'PTokenName'. This can be useful for tagging - tokens for extra safety. - - @since 1.0.0 --} -pscriptHashToTokenName :: forall (s :: S). Term s PScriptHash -> Term s PTokenName -pscriptHashToTokenName = punsafeCoerce - {- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'. @since 0.1.0 @@ -110,62 +31,6 @@ pscriptHashToTokenName = punsafeCoerce validatorHashToAddress :: ValidatorHash -> Address validatorHashToAddress vh = Address (ScriptCredential vh) Nothing -{- | Compare two 'PAsData' value, return true if the first one is less than the second one. - - @since 0.2.0 --} -pltAsData :: - forall (a :: PType) (s :: S). - (POrd a, PIsData a) => - Term s (PAsData a :--> PAsData a :--> PBool) -pltAsData = phoistAcyclic $ - plam $ - \(pfromData -> l) (pfromData -> r) -> l #< r - -{- | Extract data stored in a 'PBuiltinPair' and call a function to process it. - - @since 0.2.0 --} -withBuiltinPairAsData :: - forall (a :: PType) (b :: PType) (c :: PType) (s :: S). - (PIsData a, PIsData b) => - (Term s a -> Term s b -> Term s c) -> - Term - s - (PBuiltinPair (PAsData a) (PAsData b)) -> - Term s c -withBuiltinPairAsData f p = - let a = pfromData $ pfstBuiltin # p - b = pfromData $ psndBuiltin # p - in f a b - --- | @since 1.0.0 -plistEqualsBy :: - forall - (list1 :: PType -> PType) - (list2 :: PType -> PType) - (a :: PType) - (b :: PType) - (s :: S). - (PIsListLike list1 a, PIsListLike list2 b) => - Term s ((a :--> b :--> PBool) :--> list1 a :--> list2 b :--> PBool) -plistEqualsBy = phoistAcyclic $ - plam $ \eq -> pfix #$ plam $ \self l1 l2 -> - pelimList - ( \x xs -> - pelimList - ( \y ys -> - -- Avoid comparison if two lists have different length. - self # xs # ys #&& eq # x # y - ) - -- l2 is empty, but l1 is not. - (pconstant False) - l2 - ) - -- l1 is empty, so l2 should be empty as well. - (pnull # l2) - l1 - -- | @since 1.0.0 pstringIntercalate :: forall (s :: S). @@ -183,225 +48,6 @@ punwords :: Term s PString punwords = pstringIntercalate " " --- | @since 1.0.0 -pcurrentTimeDuration :: - forall (s :: S). - Term - s - ( PCurrentTime - :--> PPOSIXTime - ) -pcurrentTimeDuration = phoistAcyclic $ - plam $ - flip pmatch $ - \(PCurrentTime lb ub) -> ub - lb - -{- | / O(n) /. Remove the first occurance of a value from the given list. - - @since 1.0.0 --} -pdelete :: - forall (a :: PType) (list :: PType -> PType) (s :: S). - (PEq a, PIsListLike list a) => - Term s (a :--> list a :--> PMaybe (list a)) -pdelete = phoistAcyclic $ pdeleteBy # plam (#==) - --- | @since 1.0.0 -pdeleteBy :: - forall (a :: PType) (list :: PType -> PType) (s :: S). - (PIsListLike list a) => - Term s ((a :--> a :--> PBool) :--> a :--> list a :--> PMaybe (list a)) -pdeleteBy = phoistAcyclic $ - plam $ \f' x -> plet (f' # x) $ \f -> - precList - ( \self h t -> - pif - (f # h) - (pjust # t) - (pfmap # (pcons # h) # (self # t)) - ) - (const pnothing) - --- | @since 1.0.0 -pmustDeleteBy :: - forall (a :: PType) (list :: PType -> PType) (s :: S). - (PIsListLike list a) => - Term s ((a :--> a :--> PBool) :--> a :--> list a :--> list a) -pmustDeleteBy = phoistAcyclic $ - plam $ \f' x -> plet (f' # x) $ \f -> - precList - ( \self h t -> - pif - (f # h) - t - (pcons # h #$ self # t) - ) - (const $ ptraceError "Cannot delete element") - -{- | / O(1) /.Return true if the given list has only one element. - - @since 1.0.0 --} -pisSingleton :: - forall (a :: PType) (list :: PType -> PType) (s :: S). - (PIsListLike list a) => - Term s (list a :--> PBool) -pisSingleton = - phoistAcyclic $ - precList - (\_ _ t -> pnull # t) - (const $ pconstant False) - -{- Throws an error if the given list contains zero or more than one elements. - Otherwise returns the only element. - - @since 1.0.0 --} -pfromSingleton :: - forall (a :: PType) (list :: PType -> PType) (s :: S). - (PIsListLike list a) => - Term s (list a :--> a) -pfromSingleton = - phoistAcyclic $ - precList - ( \_ h t -> - pif - (pnull # t) - h - (ptraceError "More than one element") - ) - (const $ ptraceError "Empty list") - -{- | A version of 'pmap' which can throw out elements and change the list type - along the way. - - @since 1.0.0 --} -pmapMaybe :: - forall - (listO :: PType -> PType) - (b :: PType) - (listI :: PType -> PType) - (a :: PType) - (s :: S). - (PIsListLike listI a, PIsListLike listO b) => - Term s ((a :--> PMaybe b) :--> listI a :--> listO b) -pmapMaybe = phoistAcyclic $ - plam $ \f -> - precList - ( \self h t -> - pmatch - (f # h) - ( \case - PJust x -> pcons # x - PNothing -> pidentity - ) - # (self # t) - ) - (const pnil) - -infixl 3 #<|> - --- | @since 1.0.0 -class (PApplicative f) => PAlternative (f :: PType -> PType) where - (#<|>) :: - forall (a :: PType) (s :: S). - (PSubcategory f a) => - Term s (f a :--> f a :--> f a) - pempty :: - forall (a :: PType) (s :: S). - (PSubcategory f a) => - Term s (f a) - --- | @since 1.0.0 -instance PAlternative PMaybe where - (#<|>) = phoistAcyclic $ - plam $ \a b -> pmatch a $ \case - PNothing -> b - PJust _ -> a - pempty = pnothing - --- | @since 1.0.0 -ppureIf :: - forall - (f :: PType -> PType) - (a :: PType) - (s :: S). - (PAlternative f, PSubcategory f a) => - Term s (PBool :--> a :--> f a) -ppureIf = phoistAcyclic $ - plam $ \cond x -> - pif - cond - (ppure # x) - pempty - -{- | Less then check using a `PComparator`. - - @ since 1.0.0 --} -pltBy :: - forall (a :: PType) (s :: S). - Term - s - ( PComparator a - :--> a - :--> a - :--> PBool - ) -pltBy = phoistAcyclic $ - plam $ \c x y -> - pcompareBy # c # x # y #== pcon PLT - --- | @since 1.0.0 -pinsertUniqueBy :: - forall (list :: PType -> PType) (a :: PType) (s :: S). - (PIsListLike list a) => - Term s (PComparator a :--> a :--> list a :--> list a) -pinsertUniqueBy = phoistAcyclic $ - plam $ \c x -> - let lt = pltBy # c - eq = pequateBy # c - in precList - ( \self h t -> - let ensureUniqueness = - pif - (eq # x # h) - (ptraceError "inserted value already exists") - next = - pif - (lt # x # h) - (pcons # x #$ pcons # h # t) - (pcons # h #$ self # t) - in ensureUniqueness next - ) - (const $ psingleton # x) - --- | @since 1.0.0 -ptryFromRedeemer :: - forall (r :: PType) (s :: S). - (PTryFrom PData r) => - Term - s - ( PScriptPurpose - :--> PMap 'Unsorted PScriptPurpose PRedeemer - :--> PMaybe r - ) -ptryFromRedeemer = phoistAcyclic $ - plam $ \p m -> - pfmap - # plam (flip ptryFrom fst . pto) - # (plookup # p # m) - --- | @since 1.0.0 -passert :: - forall (a :: PType) (s :: S). - Term s PString -> - Term s PBool -> - Term s a -> - Term s a -passert msg cond x = pif cond x $ ptraceError msg - -- | @since 1.0.0 pisNothing :: forall (a :: PType) (s :: S). @@ -421,46 +67,3 @@ pisDNothing = phoistAcyclic $ flip pmatch $ \case PDNothing _ -> pconstant True _ -> pconstant False - -{- | Get the negative and positive amount of a particular 'CurrencySymbol', and - return nothing if it doesn't exist in the value. - - @since 1.0.0 --} -psymbolValueOf' :: - forall - (keys :: KeyGuarantees) - (amounts :: AmountGuarantees) - (s :: S). - Term - s - ( PCurrencySymbol - :--> PValue keys amounts - :--> PMaybe - ( PPair - -- Positive amount - PInteger - -- Negative amount - PInteger - ) - ) -psymbolValueOf' = phoistAcyclic $ - plam $ \sym value -> - let tnMap = plookup # sym # pto value - f = - plam $ - ( pfoldr - # plam - ( \x r -> - let q = pfromData $ psndBuiltin # x - in pmatch r $ \(PPair p n) -> - pif - (0 #< q) - (pcon $ PPair (p + q) n) - (pcon $ PPair p (n + q)) - ) - # pcon (PPair 0 0) - # - ) - . pto - in pfmap # f # tnMap