apply suggestions
This commit is contained in:
Emily Martins
parent
3599eadf0b
commit
8bf96802b7
8 changed files with 209 additions and 126 deletions
|
|
@ -78,6 +78,7 @@ common lang
|
|||
ViewPatterns
|
||||
OverloadedRecordDot
|
||||
QualifiedDo
|
||||
UndecidableInstances
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
|
|
|
|||
|
|
@ -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 "" "")
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue