diff --git a/agora.cabal b/agora.cabal index 12cd819..1a68b80 100644 --- a/agora.cabal +++ b/agora.cabal @@ -78,6 +78,7 @@ common lang ViewPatterns OverloadedRecordDot QualifiedDo + UndecidableInstances default-language: Haskell2010 diff --git a/bench/Main.hs b/bench/Main.hs index c03b5e4..150f528 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -4,14 +4,24 @@ import Prelude -------------------------------------------------------------------------------- -import Plutarch.Benchmark import Plutus.V1.Ledger.Value qualified as Value -------------------------------------------------------------------------------- -import Agora.AuthorityToken qualified as Agora -import Agora.SafeMoney qualified as Agora -import Agora.Stake qualified as Agora +import Plutarch.Benchmark + +-------------------------------------------------------------------------------- + +import Agora.AuthorityToken ( + AuthorityToken (AuthorityToken), + authorityTokenPolicy, + ) +import Agora.SafeMoney (LQ) +import Agora.Stake ( + Stake (Stake), + stakePolicy, + stakeValidator, + ) -------------------------------------------------------------------------------- @@ -23,7 +33,10 @@ benchmarks :: [NamedBenchmark] benchmarks = benchGroup "full_scripts" - [ bench "authorityTokenPolicy" $ Agora.authorityTokenPolicy (Agora.AuthorityToken (Value.assetClass "" "")) - , bench "stakePolicy" $ Agora.stakePolicy (Agora.Stake @Agora.LQ) - , bench "stakeValidator" $ Agora.stakeValidator (Agora.Stake @Agora.LQ) + [ bench "authorityTokenPolicy" $ authorityTokenPolicy authorityToken + , bench "stakePolicy" $ stakePolicy (Stake @LQ) + , bench "stakeValidator" $ stakeValidator (Stake @LQ) ] + +authorityToken :: AuthorityToken +authorityToken = AuthorityToken (Value.assetClass "" "") diff --git a/src/Agora/AuthorityToken.hs b/src/Agora/AuthorityToken.hs index 041633a..d374553 100644 --- a/src/Agora/AuthorityToken.hs +++ b/src/Agora/AuthorityToken.hs @@ -1,5 +1,8 @@ -{-# LANGUAGE PolyKinds #-} - +{- | +Module : Agora.AuthorityToken +Maintainer : emi@haskell.fyi +Description: Tokens acting as redeemable proofs of DAO authority +-} module Agora.AuthorityToken ( authorityTokenPolicy, AuthorityToken (..), @@ -28,7 +31,7 @@ import Agora.Utils (passert, passetClassValueOf, passetClassValueOf') moved while this token was minted. In effect, this means that the validator that locked such a token must have approved said transaction. Said validator should be made aware of - _this_ token's existence in order to prevent incorrect minting. + *this* token's existence in order to prevent incorrect minting. -} newtype AuthorityToken = AuthorityToken { authority :: AssetClass @@ -37,6 +40,7 @@ newtype AuthorityToken = AuthorityToken -------------------------------------------------------------------------------- +-- | Policy given 'AuthorityToken' params. authorityTokenPolicy :: AuthorityToken -> Term s (PData :--> PScriptContext :--> PUnit) diff --git a/src/Agora/SafeMoney.hs b/src/Agora/SafeMoney.hs index 019c179..ef09fe9 100644 --- a/src/Agora/SafeMoney.hs +++ b/src/Agora/SafeMoney.hs @@ -1,33 +1,40 @@ -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneKindSignatures #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wwarn=missing-methods #-} -{-# OPTIONS_GHC -Wwarn=unused-imports #-} +{- | +Module : Agora.SafeMoney +Maintainer : emi@haskell.fyi +Description: Phantom-type protected types for handling money in Plutus +-} +module Agora.SafeMoney ( + -- * Types + MoneyClass, + PDiscrete, -module Agora.SafeMoney (module Agora.SafeMoney) where + -- * Utility functions + paddDiscrete, + + -- * Conversions + pdiscreteValue, + pvalueDiscrete, + + -- * Example MoneyClasses + LQ, + ADA, +) where import Data.Proxy (Proxy (Proxy)) import Data.String import GHC.TypeLits ( - CmpNat, - KnownNat, KnownSymbol, Nat, - SomeNat (..), - SomeSymbol (..), Symbol, - natVal, - someNatVal, - someSymbolVal, symbolVal, ) import Prelude -------------------------------------------------------------------------------- -import Plutarch.Api.V1 -import Plutarch.Builtin -import Plutarch.Internal +import Plutarch.Api.V1 (PValue) +import Plutarch.Builtin () +import Plutarch.Internal () import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- @@ -46,72 +53,59 @@ type MoneyClass = Nat ) -newtype Discrete (mc :: MoneyClass) (s :: S) - = Discrete (Term s PInteger) - deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (Discrete mc) PInteger) +-- | A PDiscrete amount of currency tagged on the type level with the MoneyClass it belong sto +newtype PDiscrete (mc :: MoneyClass) (s :: S) + = PDiscrete (Term s PInteger) + deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete mc) PInteger) --- In the future, this should use plutarch-numeric - --- | Add two `Discrete` values of the same MoneyClass -paddDiscrete :: Term s (Discrete mc :--> Discrete mc :--> Discrete mc) +-- | Add two `PDiscrete` values of the same MoneyClass. +paddDiscrete :: Term s (PDiscrete mc :--> PDiscrete mc :--> PDiscrete mc) paddDiscrete = phoistAcyclic $ + -- In the future, this should use plutarch-numeric plam $ \x y -> P.do - Discrete x' <- pmatch x - Discrete y' <- pmatch y - pcon (Discrete $ x' + y') - -(^*) :: Term s (Discrete mc) -> Term s PInteger -> Term s (Discrete mc) -(^*) x y = pcon $ - Discrete . unTermCont $ do - Discrete x' <- tcont $ pmatch x - pure (x' * y) + PDiscrete x' <- pmatch x + PDiscrete y' <- pmatch y + pcon (PDiscrete $ x' + y') +-- | The MoneyClass of LQ. type LQ :: MoneyClass type LQ = '("da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24", "LQ", 6) +-- | The MoneyClass of ADA. type ADA :: MoneyClass type ADA = '("", "", 6) -------------------------------------------------------------------------------- --- | Downcast a 'PValue' to a 'Discrete' unit -valueDiscrete :: +-- | Downcast a 'PValue' to a 'PDiscrete' unit. +pvalueDiscrete :: forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. ( KnownSymbol ac , KnownSymbol n , moneyClass ~ '(ac, n, scale) ) => - Term s (PValue :--> Discrete moneyClass) -valueDiscrete = phoistAcyclic $ + Term s (PValue :--> PDiscrete moneyClass) +pvalueDiscrete = phoistAcyclic $ plam $ \f -> - pcon . Discrete $ + pcon . PDiscrete $ passetClassValueOf # pconstant (fromString $ symbolVal $ Proxy @ac) # pconstant (fromString $ symbolVal $ Proxy @n) # f --- NOTE: discreteValue after valueDiscrete is loses information - --- | Get a 'PValue' from a 'Discrete' -discreteValue :: +{- | Get a 'PValue' from a 'PDiscrete'. +NOTE: pdiscreteValue after pvaluePDiscrete is loses information +-} +pdiscreteValue :: forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. ( KnownSymbol ac , KnownSymbol n , moneyClass ~ '(ac, n, scale) ) => - Term s (Discrete moneyClass :--> PValue) -discreteValue = phoistAcyclic $ + Term s (PDiscrete moneyClass :--> PValue) +pdiscreteValue = phoistAcyclic $ plam $ \f -> pmatch f $ \case - Discrete p -> + PDiscrete p -> psingletonValue # pconstant (fromString $ symbolVal $ Proxy @ac) # pconstant (fromString $ symbolVal $ Proxy @n) # p - --- | Create a value with a single asset class -psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) -psingletonValue = phoistAcyclic $ - plam $ \sym tok int -> - let innerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata tok # pdata int - outerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata sym # pdata innerTup - res = pcon $ PValue outerTup - in res diff --git a/src/Agora/SafeMoney/QQ.hs b/src/Agora/SafeMoney/QQ.hs index 35d3d85..51586fa 100644 --- a/src/Agora/SafeMoney/QQ.hs +++ b/src/Agora/SafeMoney/QQ.hs @@ -1,7 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wwarn=missing-methods #-} -{-# OPTIONS_GHC -Wwarn=unused-imports #-} +{- | +Module : Agora.SafeMoney.QQ +Maintainer : emi@haskell.fyi +Description: Quasiquoter for SafeMoney types +-} module Agora.SafeMoney.QQ (discrete) where import GHC.Real (Ratio ((:%))) @@ -28,12 +31,20 @@ import Prelude import Plutarch.Internal (punsafeCoerce) -import Agora.SafeMoney +import Agora.SafeMoney (MoneyClass, PDiscrete) +-------------------------------------------------------------------------------- + +{- | Generate 'PDiscrete' values tagged by a particular MoneyClass + +@ + [discrete| 123.456 ADA |] :: 'Term' s ('PDiscrete' 'ADA') +@ +-} discrete :: QuasiQuoter discrete = QuasiQuoter discreteExp errorDiscretePat errorDiscreteType errorDiscreteDiscretelaration -discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (Discrete moneyClass) +discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (PDiscrete moneyClass) discreteConstant n = punsafeCoerce (pconstant n :: Term s PInteger) fixedToInteger :: Integer -> (Integer, Integer) -> Integer diff --git a/src/Agora/Stake.hs b/src/Agora/Stake.hs index f5834a6..fcbba21 100644 --- a/src/Agora/Stake.hs +++ b/src/Agora/Stake.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Vote-lockable stake UTXOs holding GT +{- | +Module : Agora.Stake +Maintainer : emi@haskell.fyi +Description: Vote-lockable stake UTXOs holding GT. +-} module Agora.Stake ( PStakeDatum (..), PStakeAction (..), @@ -24,27 +24,52 @@ import Prelude -------------------------------------------------------------------------------- import Plutarch (popaque) -import Plutarch.Api.V1 +import Plutarch.Api.V1 ( + PCredential (PPubKeyCredential, PScriptCredential), + PMintingPolicy, + PPubKeyHash, + PScriptPurpose (PMinting, PSpending), + PValidator, + mintingPolicySymbol, + mkMintingPolicy, + ) import Plutarch.DataRepr ( PDataFields, PIsDataReprInstances (PIsDataReprInstances), ) -import Plutarch.Internal +import Plutarch.Internal (punsafeCoerce) import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- -import Agora.SafeMoney -import Agora.Utils +import Agora.SafeMoney ( + MoneyClass, + PDiscrete, + paddDiscrete, + pdiscreteValue, + ) +import Agora.Utils ( + anyInput, + anyOutput, + paddValue, + passert, + pfindTxInByTxOutRef, + psingletonValue, + psymbolValueOf, + ptxSignedBy, + pvalueSpent, + ) -------------------------------------------------------------------------------- +-- | Parameters for creating Stake scripts. data Stake (gt :: MoneyClass) = Stake +-- | Plutarch-level redeemer for Stake scripts. data PStakeAction (gt :: MoneyClass) (s :: S) - = -- | Deposit or withdraw a discrete amount of the staked governance token - PDepositWithdraw (Term s (PDataRecord '["delta" ':= Discrete gt])) - | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets + = -- | Deposit or withdraw a discrete amount of the staked governance token. + PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete gt])) + | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets. PDestroy (Term s (PDataRecord '[])) deriving stock (GHC.Generic) deriving anyclass (Generic) @@ -53,15 +78,10 @@ data PStakeAction (gt :: MoneyClass) (s :: S) (PlutusType, PIsData) via PIsDataReprInstances (PStakeAction gt) +-- | Plutarch-level datum for Stake scripts. newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum { getStakeDatum :: - Term - s - ( PDataRecord - '[ "stakedAmount" ':= Discrete gt - , "owner" ':= PPubKeyHash - ] - ) + Term s (PDataRecord '["stakedAmount" ':= PDiscrete gt, "owner" ':= PPubKeyHash]) } deriving stock (GHC.Generic) deriving anyclass (Generic) @@ -71,20 +91,21 @@ newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum via (PIsDataReprInstances (PStakeDatum gt)) -------------------------------------------------------------------------------- --- --- What this Policy does --- --- For minting: --- Check that exactly 1 state thread is minted --- Check that an output exists with a state thread and a valid datum --- Check that no state thread is an input --- assert TokenName == ValidatorHash of the script that we pay to --- --- For burning: --- Check that exactly 1 state thread is burned --- Check that datum at state thread is valid and not locked --- +{- What this Policy does + + For minting: + Check that exactly one state thread is minted + Check that an output exists with a state thread and a valid datum + Check that no state thread is an input + assert TokenName == ValidatorHash of the script that we pay to + + For burning: + Check that exactly one state thread is burned + Check that datum at state thread is valid and not locked +-} -------------------------------------------------------------------------------- + +-- | Policy for Stake state threads stakePolicy :: forall (gt :: MoneyClass) ac n scale s. ( KnownSymbol ac @@ -148,9 +169,12 @@ stakePolicy _stake = # 1 let expectedValue = paddValue - # (discreteValue # stakeDatum.stakedAmount) + # (pdiscreteValue # stakeDatum.stakedAmount) # stValue - let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner + let ownerSignsTransaction = + ptxSignedBy + # ctx.txInfo + # stakeDatum.owner -- TODO: Needs to be >=, rather than == let valueCorrect = pdata value #== pdata expectedValue @@ -161,6 +185,8 @@ stakePolicy _stake = pif (0 #< mintedST) minting burning -------------------------------------------------------------------------------- + +-- | Validator intended for Stake UTXOs to live in stakeValidator :: forall (gt :: MoneyClass) ac n scale s. ( KnownSymbol ac @@ -174,8 +200,12 @@ stakeValidator stake = ctx <- pletFields @'["txInfo", "purpose"] ctx' txInfo' <- plet ctx.txInfo txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo' - let stakeAction = punsafeCoerce redeemer :: Term s (PStakeAction gt) - let stakeDatum' = punsafeCoerce datum :: Term s (PStakeDatum gt) + + -- Coercion is safe in that if coercion fails we crash hard. + let stakeAction :: Term _ (PStakeAction gt) + stakeAction = pfromData $ punsafeCoerce redeemer + stakeDatum' :: Term _ (PStakeDatum gt) + stakeDatum' = pfromData $ punsafeCoerce datum stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum' PSpending txOutRef <- pmatch $ pfromData ctx.purpose @@ -211,7 +241,7 @@ stakeValidator stake = let correctOutputDatum = stakeDatum.owner #== newStakeDatum.owner #&& (paddDiscrete # stakeDatum.stakedAmount # delta) #== newStakeDatum.stakedAmount - let expectedValue = paddValue # continuingValue # (discreteValue # delta) + let expectedValue = paddValue # continuingValue # (pdiscreteValue # delta) -- TODO: As above, needs to be >=, rather than == let correctValue = pdata value #== pdata expectedValue diff --git a/src/Agora/Utils.hs b/src/Agora/Utils.hs index b320339..c0967f0 100644 --- a/src/Agora/Utils.hs +++ b/src/Agora/Utils.hs @@ -1,4 +1,8 @@ --- | Plutarch utility functions that should be upstreamed or don't belong anywhere else +{- | +Module : Agora.Utils +Maintainer : emi@haskell.fyi +Description: Plutarch utility functions that should be upstreamed or don't belong anywhere else +-} module Agora.Utils ( -- * Validator-level utility functions passert, @@ -14,6 +18,7 @@ module Agora.Utils ( passetClassValueOf, passetClassValueOf', pfindTxInByTxOutRef, + psingletonValue, pfindMap, -- * Functions which should (probably) not be upstreamed @@ -50,7 +55,7 @@ import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- -- Validator-level utility functions --- | Assert a particular bool, trace on falsehood. Use in monadic context +-- | Assert a particular 'PBool', trace if false. Use in monadic context. passert :: Term s PString -> Term s PBool -> Term s k -> Term s k passert errorMessage check k = pif check k (ptraceError errorMessage) @@ -61,18 +66,20 @@ pfindDatum = phoistAcyclic $ PTxInfo txInfo' <- pmatch txInfo'' plookupTuple # datumHash #$ pfield @"data" # txInfo' --- | Find a datum with the given hash. NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. +{- | Find a datum with the given hash. +NOTE: this is unsafe in the sense that, if the data layout is wrong, this is UB. +-} pfindDatum' :: PIsData a => Term s (PDatumHash :--> PTxInfo :--> PMaybe (PAsData a)) pfindDatum' = phoistAcyclic $ plam $ \dh x -> punsafeCoerce $ pfindDatum # dh # x --- | Check if a PubKeyHash signs this transaction +-- | Check if a PubKeyHash signs this transaction. ptxSignedBy :: Term s (PTxInfo :--> PAsData PPubKeyHash :--> PBool) ptxSignedBy = phoistAcyclic $ plam $ \txInfo' pkh -> P.do txInfo <- pletFields @'["signatories"] txInfo' pelem @PBuiltinList # pkh # txInfo.signatories --- | Get the first element that matches a predicate or return Nothing +-- | Get the first element that matches a predicate or return Nothing. pfind' :: PIsListLike list a => (Term s a -> Term s PBool) -> @@ -82,7 +89,7 @@ pfind' p = (\self x xs -> pif (p x) (pcon (PJust x)) (self # xs)) (const $ pcon PNothing) --- | Get the first element that maps to a PJust in a list +-- | Get the first element that maps to a PJust in a list. pfindMap :: PIsListLike list a => Term s ((a :--> PMaybe b) :--> list a :--> PMaybe b) @@ -98,7 +105,7 @@ pfindMap = ) (const $ pcon PNothing) --- | Find the value for a given key in an assoclist +-- | Find the value for a given key in an associative list. plookup :: (PEq a, PIsListLike list (PBuiltinPair a b)) => Term s (a :--> list (PBuiltinPair a b) :--> PMaybe b) @@ -109,7 +116,7 @@ plookup = PNothing -> pcon PNothing PJust p -> pcon (PJust (psndBuiltin # p)) --- | Find the value for a given key in an assoclist which uses 'PTuple's +-- | Find the value for a given key in an assoclist which uses 'PTuple's. plookupTuple :: (PEq a, PIsListLike list (PAsData (PTuple a b)), PIsData a, PIsData b) => Term s (a :--> list (PAsData (PTuple a b)) :--> PMaybe b) @@ -120,7 +127,7 @@ plookupTuple = PNothing -> pcon PNothing PJust p -> pcon (PJust (pfield @"_1" # pfromData p)) --- | Extract a Maybe by providing a default value in case of Just +-- | Extract a Maybe by providing a default value in case of Just. pfromMaybe :: forall a s. Term s (a :--> PMaybe a :--> a) pfromMaybe = phoistAcyclic $ plam $ \e a -> @@ -128,14 +135,19 @@ pfromMaybe = phoistAcyclic $ PJust a' -> a' PNothing -> e --- | Escape with a particular value on expecting 'Just'. For use in monadic context -pexpectJust :: forall r a s. Term s r -> Term s (PMaybe a) -> (Term s a -> Term s r) -> Term s r +-- | Escape with a particular value on expecting 'Just'. For use in monadic context. +pexpectJust :: + forall r a s. + Term s r -> + Term s (PMaybe a) -> + (Term s a -> Term s r) -> + Term s r pexpectJust escape ma f = pmatch ma $ \case PJust v -> f v PNothing -> escape --- | Get the sum of all values belonging to a particular CurrencySymbol +-- | Get the sum of all values belonging to a particular CurrencySymbol. psymbolValueOf :: Term s (PCurrencySymbol :--> PValue :--> PInteger) psymbolValueOf = phoistAcyclic $ @@ -146,7 +158,7 @@ psymbolValueOf = PMap m <- pmatch (pfromData m') pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m --- | Extract amount from PValue belonging to a Plutarch-level asset class +-- | Extract amount from PValue belonging to a Plutarch-level asset class. passetClassValueOf :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PInteger) passetClassValueOf = @@ -159,12 +171,12 @@ passetClassValueOf = v <- pexpectJust 0 (plookup # pdata token # m) pfromData v --- | Extract amount from PValue belonging to a Haskell-level AssetClass +-- | Extract amount from PValue belonging to a Haskell-level AssetClass. passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger) passetClassValueOf' (AssetClass (sym, token)) = passetClassValueOf # pconstant sym # pconstant token --- | Union two maps using a merge function on collisions +-- | Union two maps using a merge function on collisions. pmapUnionWith :: forall k v s. PIsData v => Term s ((v :--> v :--> v) :--> PMap k v :--> PMap k v :--> PMap k v) pmapUnionWith = phoistAcyclic $ -- TODO: this function is kinda suspect. I feel like a lot of optimizations could be done here @@ -204,7 +216,7 @@ paddValue = phoistAcyclic $ pmapUnionWith # plam (\a' b' -> pmapUnionWith # plam (+) # a' # b') # a # b ) --- | Sum of all value at input +-- | Sum of all value at input. pvalueSpent :: Term s (PTxInfo :--> PValue) pvalueSpent = phoistAcyclic $ plam $ \txInfo' -> @@ -216,13 +228,15 @@ pvalueSpent = phoistAcyclic $ (pfromData txInInfo') $ \(PTxInInfo txInInfo) -> paddValue - # pmatch (pfield @"resolved" # txInInfo) (\(PTxOut o) -> pfromData $ pfield @"value" # o) + # pmatch + (pfield @"resolved" # txInInfo) + (\(PTxOut o) -> pfromData $ pfield @"value" # o) # v ) # pconstant mempty # (pfield @"inputs" # txInfo) --- | Find the TxInInfo by a TxOutRef +-- | Find the TxInInfo by a TxOutRef. pfindTxInByTxOutRef :: Term s (PTxOutRef :--> PTxInfo :--> PMaybe PTxInInfo) pfindTxInByTxOutRef = phoistAcyclic $ plam $ \txOutRef txInfo' -> @@ -242,7 +256,7 @@ pfindTxInByTxOutRef = phoistAcyclic $ -------------------------------------------------------------------------------- -- Functions which should (probably) not be upstreamed --- | Check if any output matches the predicate +-- | Check if any output matches the predicate. anyOutput :: forall (datum :: PType) s. ( PIsData datum @@ -264,7 +278,7 @@ anyOutput = phoistAcyclic $ ) # pfromData txInfo.outputs --- | Check if any (resolved) input matches the predicate +-- | Check if any (resolved) input matches the predicate. anyInput :: forall (datum :: PType) s. ( PIsData datum @@ -287,3 +301,12 @@ anyInput = phoistAcyclic $ PNothing -> pcon PFalse ) # pfromData txInfo.inputs + +-- | Create a value with a single asset class. +psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue) +psingletonValue = phoistAcyclic $ + plam $ \sym tok int -> + let innerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata tok # pdata int + outerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata sym # pdata innerTup + res = pcon $ PValue outerTup + in res diff --git a/src/Agora/Voting.hs b/src/Agora/Voting.hs index 74354a5..5436960 100644 --- a/src/Agora/Voting.hs +++ b/src/Agora/Voting.hs @@ -1,4 +1,11 @@ --- | Types for votes and vote counting -module Agora.Voting (Vote (..)) where +{- | +Module : Agora.Voting +Maintainer : emi@haskell.fyi +Description: Types for votes and vote counting +-} +module Agora.Voting ( + Vote (..), +) where +-- | Type representing direction of vote. data Vote = InFavorOf | OpposedTo