Merge pull request #42 from Liqwid-Labs/emiflake/stub-everything
Stub out most components
This commit is contained in:
Emily
GitHub
commit
dd30fc51b1
19 changed files with 487 additions and 331 deletions
1
Makefile
1
Makefile
|
|
@ -12,6 +12,7 @@ usage:
|
|||
@echo " haddock -- Generate Haddock docs for project"
|
||||
|
||||
hoogle:
|
||||
pkill hoogle || true
|
||||
hoogle generate --local=haddock --database=hoo/local.hoo
|
||||
hoogle server --local -p 8081 >> /dev/null &
|
||||
hoogle server --local --database=hoo/local.hoo -p 8082 >> /dev/null &
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ import Test.Tasty (defaultMain, testGroup)
|
|||
import Spec.Model.MultiSig qualified as MultiSig
|
||||
import Spec.Stake qualified as Stake
|
||||
|
||||
-- | The Agora test suite
|
||||
-- | The Agora test suite.
|
||||
main :: IO ()
|
||||
main =
|
||||
defaultMain $
|
||||
|
|
|
|||
|
|
@ -171,7 +171,7 @@ instance ScriptModel MultiSigProp MultiSigModel where
|
|||
(pcon PUnit)
|
||||
perror
|
||||
|
||||
-- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel'
|
||||
-- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel'.
|
||||
genTests :: TestTree
|
||||
genTests =
|
||||
testGroup "genTests" $
|
||||
|
|
@ -182,7 +182,7 @@ genTests =
|
|||
Yes
|
||||
]
|
||||
|
||||
-- | Tests for the 'ScriptModel' instance of 'MultiSigModel'
|
||||
-- | Tests for the 'ScriptModel' instance of 'MultiSigModel'.
|
||||
plutarchTests :: TestTree
|
||||
plutarchTests =
|
||||
testGroup "plutarchTests" $
|
||||
|
|
|
|||
|
|
@ -21,7 +21,6 @@ module Spec.Sample.Stake (
|
|||
) where
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Api.V1 (
|
||||
mintingPolicySymbol,
|
||||
mkMintingPolicy,
|
||||
|
|
@ -47,7 +46,7 @@ import Plutus.V1.Ledger.Api (
|
|||
import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
|
||||
import Plutus.V1.Ledger.Interval qualified as Interval
|
||||
import Plutus.V1.Ledger.Scripts (Validator)
|
||||
import Plutus.V1.Ledger.Value (TokenName (TokenName))
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), TokenName (TokenName))
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
@ -59,8 +58,17 @@ import Spec.Util (datumPair, toDatumHash)
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | 'Stake' parameters for 'LQ'.
|
||||
stake :: Stake LQ
|
||||
stake = Stake
|
||||
stake :: Stake
|
||||
stake =
|
||||
Stake
|
||||
{ gtClassRef =
|
||||
AssetClassRef
|
||||
( AssetClass
|
||||
( "da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
, "LQ"
|
||||
)
|
||||
)
|
||||
}
|
||||
|
||||
-- | 'Stake' policy instance.
|
||||
policy :: MintingPolicy
|
||||
|
|
@ -135,9 +143,9 @@ stakeCreationUnsigned =
|
|||
|
||||
-- | Config for creating a ScriptContext that deposits or withdraws.
|
||||
data DepositWithdrawExample = DepositWithdrawExample
|
||||
{ startAmount :: Integer
|
||||
{ startAmount :: Discrete GTTag
|
||||
-- ^ The amount of GT stored before the transaction.
|
||||
, delta :: Integer
|
||||
, delta :: Discrete GTTag
|
||||
-- ^ The amount of GT deposited or withdrawn from the Stake.
|
||||
}
|
||||
|
||||
|
|
@ -160,10 +168,7 @@ stakeDepositWithdraw config =
|
|||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
, txOutValue =
|
||||
st
|
||||
<> Value.singleton
|
||||
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
"LQ"
|
||||
stakeBefore.stakedAmount
|
||||
<> discreteValue stake.gtClassRef stakeBefore.stakedAmount
|
||||
, txOutDatumHash = Just (toDatumHash stakeAfter)
|
||||
}
|
||||
]
|
||||
|
|
@ -172,10 +177,7 @@ stakeDepositWithdraw config =
|
|||
{ txOutAddress = Address (ScriptCredential $ validatorHash validator) Nothing
|
||||
, txOutValue =
|
||||
st
|
||||
<> Value.singleton
|
||||
"da8c30857834c6ae7203935b89278c532b3995245295456f993e1d24"
|
||||
"LQ"
|
||||
stakeAfter.stakedAmount
|
||||
<> discreteValue stake.gtClassRef stakeAfter.stakedAmount
|
||||
, txOutDatumHash = Just (toDatumHash stakeAfter)
|
||||
}
|
||||
]
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
{- |
|
||||
Module : Spec.Stake
|
||||
Maintainer : emi@haskell.fyi
|
||||
|
|
@ -27,7 +29,7 @@ import Spec.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWi
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Stake tests
|
||||
-- | Stake tests.
|
||||
tests :: [TestTree]
|
||||
tests =
|
||||
[ testGroup
|
||||
|
|
@ -57,13 +59,13 @@ tests =
|
|||
"stakeDepositWithdraw withdraw"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer)
|
||||
(toDatum $ DepositWithdraw (negate 100_000))
|
||||
(toDatum $ DepositWithdraw $ negate 100_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 100_000})
|
||||
, validatorFailsWith
|
||||
"stakeDepositWithdraw negative GT"
|
||||
(stakeValidator Stake.stake)
|
||||
(toDatum $ StakeDatum 100_000 signer)
|
||||
(toDatum $ DepositWithdraw (negate 1_000_000))
|
||||
(toDatum $ DepositWithdraw 1_000_000)
|
||||
(Stake.stakeDepositWithdraw $ DepositWithdrawExample {startAmount = 100_000, delta = negate 1_000_000})
|
||||
]
|
||||
]
|
||||
|
|
|
|||
|
|
@ -96,6 +96,7 @@ common deps
|
|||
, generics-sop
|
||||
, plutarch
|
||||
, plutarch-extra
|
||||
, plutarch-numeric
|
||||
, plutus-core
|
||||
, plutus-ledger-api
|
||||
, plutus-tx
|
||||
|
|
@ -122,10 +123,11 @@ library
|
|||
Agora.AuthorityToken
|
||||
Agora.MultiSig
|
||||
Agora.SafeMoney
|
||||
Agora.SafeMoney.QQ
|
||||
Agora.Stake
|
||||
Agora.Effect
|
||||
Agora.Treasury
|
||||
Agora.Voting
|
||||
Agora.Governor
|
||||
Agora.Proposal
|
||||
|
||||
other-modules:
|
||||
Agora.Utils
|
||||
|
|
|
|||
37
agora/Agora/Effect.hs
Normal file
37
agora/Agora/Effect.hs
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
{- |
|
||||
Module : Agora.Effect
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Helpers for constructing effects
|
||||
|
||||
Helpers for constructing effects.
|
||||
-}
|
||||
module Agora.Effect (makeEffect) where
|
||||
|
||||
import Plutarch.Api.V1 (PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator)
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
import Plutarch.Monadic qualified as P
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Helper "template" for creating effect validator.
|
||||
makeEffect ::
|
||||
forall (datum :: PType) (s :: S).
|
||||
PIsData datum =>
|
||||
(Term s datum -> Term s PTxOutRef -> Term s PTxInfo -> Term s POpaque) ->
|
||||
Term s PValidator
|
||||
makeEffect f =
|
||||
plam $ \datum _redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
||||
let datum' :: Term _ datum
|
||||
datum' = pfromData $ punsafeCoerce datum
|
||||
|
||||
PSpending txOutRef <- pmatch $ pfromData ctx.purpose
|
||||
txOutRef' <- plet (pfield @"_0" # txOutRef)
|
||||
|
||||
-- TODO: Here, check that a *single* GAT is burned.
|
||||
|
||||
f datum' txOutRef' txInfo'
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
33
agora/Agora/Governor.hs
Normal file
33
agora/Agora/Governor.hs
Normal file
|
|
@ -0,0 +1,33 @@
|
|||
{- |
|
||||
Module : Agora.Governor
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Governor entity scripts acting as authority of entire system.
|
||||
|
||||
Governor entity scripts acting as authority of entire system.
|
||||
-}
|
||||
module Agora.Governor (GovernorDatum (..), GovernorRedeemer (..), Governor (..)) where
|
||||
|
||||
import Agora.Proposal (ProposalThresholds)
|
||||
|
||||
-- | Datum for the Governor script.
|
||||
newtype GovernorDatum = GovernorDatum
|
||||
{ proposalThresholds :: ProposalThresholds
|
||||
-- ^ Gets copied over upon creation of a 'Agora.Proposal.ProposalDatum'.
|
||||
}
|
||||
|
||||
{- | Redeemer for Governor script. The governor has two primary
|
||||
responsibilities:
|
||||
|
||||
1. The gating of Proposal creation.
|
||||
2. The gating of minting authority tokens.
|
||||
-}
|
||||
data GovernorRedeemer
|
||||
= -- | Checks that a proposal was created lawfully, and allows it.
|
||||
CreateProposal
|
||||
| -- | Checks that a SINGLE proposal finished correctly,
|
||||
-- and allows minting GATs for each effect script.
|
||||
MintGATs
|
||||
|
||||
-- | Parameters for creating Governor scripts.
|
||||
data Governor
|
||||
= Governor
|
||||
|
|
@ -77,13 +77,13 @@ deriving via (DerivePConstantViaData MultiSig PMultiSig) instance (PConstant Mul
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Check if a Haskell-level MultiSig signs this transaction
|
||||
-- | Check if a Haskell-level MultiSig signs this transaction.
|
||||
validatedByMultisig :: MultiSig -> Term s (PTxInfo :--> PBool)
|
||||
validatedByMultisig params =
|
||||
phoistAcyclic $
|
||||
pvalidatedByMultisig # pconstant params
|
||||
|
||||
-- | Check if a Plutarch-level MultiSig signs this transaction
|
||||
-- | Check if a Plutarch-level MultiSig signs this transaction.
|
||||
pvalidatedByMultisig :: Term s (PMultiSig :--> PTxInfo :--> PBool)
|
||||
pvalidatedByMultisig =
|
||||
phoistAcyclic $
|
||||
|
|
|
|||
208
agora/Agora/Proposal.hs
Normal file
208
agora/Agora/Proposal.hs
Normal file
|
|
@ -0,0 +1,208 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.Proposal
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Proposal scripts encoding effects that operate on the system.
|
||||
|
||||
Proposal scripts encoding effects that operate on the system.
|
||||
-}
|
||||
module Agora.Proposal (
|
||||
-- * Haskell-land
|
||||
Proposal (..),
|
||||
ProposalDatum (..),
|
||||
ProposalStatus (..),
|
||||
ProposalThresholds (..),
|
||||
ProposalVotes (..),
|
||||
ResultTag (..),
|
||||
|
||||
-- * Plutarch-land
|
||||
PProposalDatum (..),
|
||||
PResultTag (..),
|
||||
) where
|
||||
|
||||
import GHC.Generics qualified as GHC
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Plutarch.Api.V1 (
|
||||
PDatumHash,
|
||||
PMap,
|
||||
PPubKeyHash,
|
||||
PValidatorHash,
|
||||
)
|
||||
import Plutarch.DataRepr (
|
||||
PDataFields,
|
||||
PIsDataReprInstances (PIsDataReprInstances),
|
||||
)
|
||||
import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
|
||||
import PlutusTx qualified
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.SafeMoney (Discrete, GTTag, PDiscrete)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Haskell-land
|
||||
|
||||
{- | Encodes a result. Typically, for a Yes/No proposal, we encode it like this:
|
||||
|
||||
@
|
||||
"No" ~ 'ResultTag' 0
|
||||
"Yes" ~ 'ResultTag' 1
|
||||
@
|
||||
-}
|
||||
newtype ResultTag = ResultTag {getResultTag :: Integer}
|
||||
deriving stock (Eq, Show)
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
|
||||
{- | The "status" of the proposal. This is only useful for state transitions,
|
||||
as opposed to time-based "phases".
|
||||
|
||||
If the proposal is 'VotingReady', for instance, that doesn't necessarily
|
||||
mean that voting is possible, as this also requires the timing to be right.
|
||||
-}
|
||||
data ProposalStatus
|
||||
= -- | A draft proposal represents a proposal that has yet to be realized.
|
||||
--
|
||||
-- In effect, this means one which didn't have enough LQ to be a full
|
||||
-- proposal, and needs cosigners to enable that to happen. This is
|
||||
-- similar to a "temperature check", but only useful if multiple people
|
||||
-- want to pool governance tokens together. If the proposal doesn't get to
|
||||
-- 'VotingReady' on time, the proposal will __never__ be able to get
|
||||
-- voted on.
|
||||
Draft
|
||||
| -- | The proposal has/had enough GT cosigned in order to be a fully fledged
|
||||
-- proposal.
|
||||
--
|
||||
-- This means that once the timing requirements align,
|
||||
-- proposal will be able to be voted on.
|
||||
VotingReady
|
||||
| -- | The proposal has finished.
|
||||
--
|
||||
-- This can mean it's been voted on and completed, but it can also mean
|
||||
-- the proposal failed due to time constraints or didn't
|
||||
-- get to 'VotingReady' first.
|
||||
--
|
||||
-- TODO: The owner of the proposal may choose to reclaim their proposal.
|
||||
Finished
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalStatus [('Draft, 0), ('VotingReady, 1), ('Finished, 2)]
|
||||
|
||||
{- | The threshold values for various state transitions to happen.
|
||||
This data is stored centrally (in the 'Agora.Governor.Governor') and copied over
|
||||
to 'Proposal's when they are created.
|
||||
-}
|
||||
data ProposalThresholds = ProposalThresholds
|
||||
{ execute :: Discrete GTTag
|
||||
-- ^ How much GT minimum must a particular 'ResultTag' accumulate for it to pass.
|
||||
, draft :: Discrete GTTag
|
||||
-- ^ How much GT required to "create" a proposal.
|
||||
, vote :: Discrete GTTag
|
||||
-- ^ How much GT required to allow voting to happen.
|
||||
-- (i.e. to move into 'VotingReady')
|
||||
}
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalThresholds [('ProposalThresholds, 0)]
|
||||
|
||||
{- | Map which encodes the total tally for each result.
|
||||
It's important that the "shape" is consistent with the shape of 'effects'.
|
||||
|
||||
e.g. if the 'effects' field looks like the following:
|
||||
|
||||
@[('ResultTag' 0, []), ('ResultTag' 1, [(vh, dh)])]@
|
||||
|
||||
Then 'ProposalVotes' needs be of the shape:
|
||||
|
||||
@[('ResultTag' 0, n), ('ResultTag' 1, m)]@
|
||||
-}
|
||||
newtype ProposalVotes = ProposalVotes
|
||||
{ getProposalVotes :: [(ResultTag, Integer)]
|
||||
}
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
|
||||
-- | Haskell-level datum for Proposal scripts.
|
||||
data ProposalDatum = ProposalDatum
|
||||
{ -- TODO: could we encode this more efficiently?
|
||||
-- This is shaped this way for future proofing.
|
||||
-- See https://github.com/Liqwid-Labs/agora/issues/39
|
||||
effects :: [(ResultTag, [(ValidatorHash, DatumHash)])]
|
||||
-- ^ Effect lookup table. First by result, then by effect hash.
|
||||
, status :: ProposalStatus
|
||||
-- ^ The status the proposal is in.
|
||||
, cosigners :: [PubKeyHash]
|
||||
-- ^ Who created the proposal initially, and who cosigned it later.
|
||||
, thresholds :: ProposalThresholds
|
||||
-- ^ Thresholds copied over on initialization.
|
||||
, votes :: ProposalVotes
|
||||
-- ^ Vote tally on the proposal
|
||||
}
|
||||
|
||||
PlutusTx.makeIsDataIndexed ''ProposalDatum [('ProposalDatum, 0)]
|
||||
|
||||
-- | Parameters that identify the Proposal validator script.
|
||||
data Proposal = Proposal
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Plutarch-land
|
||||
|
||||
-- | Plutarch-level version of 'ResultTag'.
|
||||
newtype PResultTag (s :: S) = PResultTag (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype PResultTag PInteger)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalStatus'.
|
||||
data PProposalStatus (s :: S)
|
||||
= -- TODO: 'PProposalStatus' ought te be encoded as 'PInteger'.
|
||||
-- e.g. like Tilde used 'pmatchEnum'.
|
||||
PDraft (Term s (PDataRecord '[]))
|
||||
| PVotingReady (Term s (PDataRecord '[]))
|
||||
| PFinished (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances PProposalStatus
|
||||
|
||||
-- | Plutarch-level version of 'ProposalThresholds'.
|
||||
newtype PProposalThresholds (s :: S) = PProposalThresholds
|
||||
{ getProposalThresholds ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "execute" ':= PDiscrete GTTag
|
||||
, "draft" ':= PDiscrete GTTag
|
||||
, "vote" ':= PDiscrete GTTag
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalThresholds)
|
||||
|
||||
-- | Plutarch-level version of 'ProposalVotes'.
|
||||
newtype PProposalVotes (s :: S)
|
||||
= PProposalVotes (Term s (PMap PResultTag PInteger))
|
||||
deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap PResultTag PInteger))
|
||||
|
||||
-- | Plutarch-level version of 'ProposalDatum'.
|
||||
newtype PProposalDatum (s :: S) = PProposalDatum
|
||||
{ getProposalDatum ::
|
||||
Term
|
||||
s
|
||||
( PDataRecord
|
||||
'[ "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
|
||||
, "status" ':= PProposalStatus
|
||||
, "cosigners" ':= PBuiltinList PPubKeyHash
|
||||
, "thresholds" ':= PProposalThresholds
|
||||
, "votes" ':= PProposalVotes
|
||||
]
|
||||
)
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances PProposalDatum)
|
||||
|
|
@ -7,8 +7,14 @@ Phantom-type protected types for handling money in Plutus.
|
|||
-}
|
||||
module Agora.SafeMoney (
|
||||
-- * Types
|
||||
MoneyClass,
|
||||
PDiscrete,
|
||||
PDiscrete (..),
|
||||
Discrete (..),
|
||||
|
||||
-- * Tags and refs
|
||||
AssetClassRef (..),
|
||||
ADATag,
|
||||
GTTag,
|
||||
adaRef,
|
||||
|
||||
-- * Utility functions
|
||||
paddDiscrete,
|
||||
|
|
@ -18,24 +24,17 @@ module Agora.SafeMoney (
|
|||
-- * Conversions
|
||||
pdiscreteValue,
|
||||
pvalueDiscrete,
|
||||
|
||||
-- * Example MoneyClasses
|
||||
LQ,
|
||||
ADA,
|
||||
discreteValue,
|
||||
) where
|
||||
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.String
|
||||
import GHC.TypeLits (
|
||||
KnownSymbol,
|
||||
Nat,
|
||||
Symbol,
|
||||
symbolVal,
|
||||
)
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutus.V1.Ledger.Value (AssetClass (AssetClass), Value)
|
||||
import Plutus.V1.Ledger.Value qualified as Value
|
||||
import PlutusTx qualified
|
||||
|
||||
import Plutarch.Api.V1 (PValue)
|
||||
import Plutarch.Builtin ()
|
||||
import Plutarch.Internal ()
|
||||
|
|
@ -43,39 +42,66 @@ import Plutarch.Monadic qualified as P
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.Utils (passetClassValueOf, psingletonValue)
|
||||
import Agora.Utils (
|
||||
passetClassValueOf',
|
||||
psingletonValue,
|
||||
)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Example tags
|
||||
|
||||
-- | Governance token.
|
||||
data GTTag
|
||||
|
||||
-- | ADA.
|
||||
data ADATag
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Type-level unique identifier for an 'Plutus.V1.Ledger.Value.AssetClass'
|
||||
type MoneyClass =
|
||||
( -- AssetClass
|
||||
Symbol
|
||||
, -- TokenName
|
||||
Symbol
|
||||
, -- Decimal places
|
||||
Nat
|
||||
)
|
||||
-- | A tagged AssetClass. Use to resolve a reference inside of a PDiscrete
|
||||
newtype AssetClassRef (tag :: Type) = AssetClassRef {getAssetClass :: AssetClass}
|
||||
|
||||
-- | A 'PDiscrete' amount of currency tagged on the type level with the 'MoneyClass' it belongs to
|
||||
newtype PDiscrete (mc :: MoneyClass) (s :: S)
|
||||
-- | Resolves ada tags.
|
||||
adaRef :: AssetClassRef ADATag
|
||||
adaRef = AssetClassRef (AssetClass ("", ""))
|
||||
|
||||
-- TODO: Currently it's possible to transmute from one discrete to another.
|
||||
-- How do we prevent this?
|
||||
--
|
||||
-- @
|
||||
-- transmute :: forall (a :: Type) (b :: Type). Discrete a -> Discrete b
|
||||
-- transmute = Discrete . getDiscrete
|
||||
-- @
|
||||
|
||||
{- | Represents a single asset in a 'Plutus.V1.Ledger.Value.Value' related to a particular 'AssetClass'
|
||||
through 'AssetClassRef'.
|
||||
-}
|
||||
newtype Discrete (tag :: Type) = Discrete {getDiscrete :: Integer}
|
||||
deriving stock (Show, Eq)
|
||||
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
|
||||
deriving newtype (Num) -- TODO: Use plutarch-numeric
|
||||
|
||||
{- | Represents a single asset in a 'PValue' related to a particular 'AssetClass'
|
||||
through 'AssetClassRef'.
|
||||
-}
|
||||
newtype PDiscrete (tag :: Type) (s :: S)
|
||||
= PDiscrete (Term s PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete mc) PInteger)
|
||||
deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete tag) PInteger)
|
||||
|
||||
-- | Check if one 'PDiscrete' is greater than another.
|
||||
pgeqDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc :--> PDiscrete mc :--> PBool)
|
||||
pgeqDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PBool)
|
||||
pgeqDiscrete = phoistAcyclic $
|
||||
plam $ \x y -> P.do
|
||||
PDiscrete x' <- pmatch x
|
||||
PDiscrete y' <- pmatch y
|
||||
y' #<= x'
|
||||
|
||||
-- | Returns a zero-value 'PDiscrete' unit for any 'MoneyClass'.
|
||||
pzeroDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc)
|
||||
-- | Returns a zero-value 'PDiscrete' unit for any tag.
|
||||
pzeroDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag)
|
||||
pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0)
|
||||
|
||||
-- | Add two 'PDiscrete' values of the same 'MoneyClass'.
|
||||
paddDiscrete :: Term s (PDiscrete mc :--> PDiscrete mc :--> PDiscrete mc)
|
||||
-- | Add two 'PDiscrete' values of the same tag.
|
||||
paddDiscrete :: forall (tag :: Type) (s :: S). Term s (PDiscrete tag :--> PDiscrete tag :--> PDiscrete tag)
|
||||
paddDiscrete = phoistAcyclic $
|
||||
-- In the future, this should use plutarch-numeric
|
||||
plam $ \x y -> P.do
|
||||
|
|
@ -83,46 +109,38 @@ paddDiscrete = phoistAcyclic $
|
|||
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 `PDiscrete` unit.
|
||||
pvalueDiscrete ::
|
||||
forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s.
|
||||
( KnownSymbol ac
|
||||
, KnownSymbol n
|
||||
, moneyClass ~ '(ac, n, scale)
|
||||
) =>
|
||||
Term s (PValue :--> PDiscrete moneyClass)
|
||||
pvalueDiscrete = phoistAcyclic $
|
||||
forall (tag :: Type) (s :: S).
|
||||
AssetClassRef tag ->
|
||||
Term s (PValue :--> PDiscrete tag)
|
||||
pvalueDiscrete (AssetClassRef ac) = phoistAcyclic $
|
||||
plam $ \f ->
|
||||
pcon . PDiscrete $
|
||||
passetClassValueOf # pconstant (fromString $ symbolVal $ Proxy @ac)
|
||||
# pconstant (fromString $ symbolVal $ Proxy @n)
|
||||
# f
|
||||
pcon . PDiscrete $ passetClassValueOf' ac # f
|
||||
|
||||
{- | Get a `PValue` from a `PDiscrete`.
|
||||
__NOTE__: `pdiscreteValue` after `pvalueDiscrete` is not a round-trip.
|
||||
It filters for a particular 'MoneyClass'.
|
||||
It filters for a particular tag.
|
||||
-}
|
||||
pdiscreteValue ::
|
||||
forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s.
|
||||
( KnownSymbol ac
|
||||
, KnownSymbol n
|
||||
, moneyClass ~ '(ac, n, scale)
|
||||
) =>
|
||||
Term s (PDiscrete moneyClass :--> PValue)
|
||||
pdiscreteValue = phoistAcyclic $
|
||||
forall (tag :: Type) (s :: S).
|
||||
AssetClassRef tag ->
|
||||
Term s (PDiscrete tag :--> PValue)
|
||||
pdiscreteValue (AssetClassRef (AssetClass (cs, tn))) = phoistAcyclic $
|
||||
plam $ \f -> pmatch f $ \case
|
||||
PDiscrete p ->
|
||||
psingletonValue
|
||||
# pconstant (fromString $ symbolVal $ Proxy @ac)
|
||||
# pconstant (fromString $ symbolVal $ Proxy @n)
|
||||
# pconstant cs
|
||||
# pconstant tn
|
||||
# p
|
||||
|
||||
-- | Get a `Value` from a `Discrete`.
|
||||
discreteValue ::
|
||||
forall (tag :: Type).
|
||||
AssetClassRef tag ->
|
||||
Discrete tag ->
|
||||
Value
|
||||
discreteValue (AssetClassRef (AssetClass (cs, tn))) (Discrete v) =
|
||||
Value.singleton cs tn v
|
||||
|
|
|
|||
|
|
@ -1,96 +0,0 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
{- |
|
||||
Module : Agora.SafeMoney.QQ
|
||||
Maintainer : emi@haskell.fyi
|
||||
Description: Quasiquoter for SafeMoney types.
|
||||
|
||||
Quasiquoter for SafeMoney types.
|
||||
-}
|
||||
module Agora.SafeMoney.QQ (discrete) where
|
||||
|
||||
import GHC.Real (Ratio ((:%)))
|
||||
import Language.Haskell.TH qualified as TH (Type)
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
|
||||
import Language.Haskell.TH.Syntax (
|
||||
Dec (TySynD),
|
||||
Exp (AppE, AppTypeE, LitE, VarE),
|
||||
Info (TyConI),
|
||||
Lit (IntegerL),
|
||||
Pat,
|
||||
Q,
|
||||
TyLit (NumTyLit, StrTyLit),
|
||||
Type (AppT, ConT, LitT, PromotedTupleT),
|
||||
lookupTypeName,
|
||||
reify,
|
||||
)
|
||||
import Text.ParserCombinators.ReadP (readP_to_S, skipSpaces)
|
||||
import Text.Read (lexP, readPrec_to_P)
|
||||
import Text.Read.Lex (Lexeme (Ident, Number), Number, numberToFixed, numberToRational)
|
||||
import Prelude
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Plutarch.Internal (punsafeCoerce)
|
||||
|
||||
import Agora.SafeMoney (MoneyClass, PDiscrete)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
{- | Generate 'PDiscrete' values tagged by a particular MoneyClass
|
||||
|
||||
@
|
||||
[discrete| 123.456 'Agora.SafeMoney.ADA' |] :: 'Term' s ('PDiscrete' 'Agora.SafeMoney.ADA')
|
||||
@
|
||||
-}
|
||||
discrete :: QuasiQuoter
|
||||
discrete = QuasiQuoter discreteExp errorDiscretePat errorDiscreteType errorDiscreteDiscretelaration
|
||||
|
||||
discreteConstant :: forall (moneyClass :: MoneyClass) s. Integer -> Term s (PDiscrete moneyClass)
|
||||
discreteConstant n = punsafeCoerce (pconstant n :: Term s PInteger)
|
||||
|
||||
fixedToInteger :: Integer -> (Integer, Integer) -> Integer
|
||||
fixedToInteger places (i, f) = i * 10 ^ places + f
|
||||
|
||||
safeIntegerUpcast :: Integer -> Number -> Either String Integer
|
||||
safeIntegerUpcast places num =
|
||||
case (numberToFixed places num, numberToRational num * 10 ^ places) of
|
||||
(Just (i, f), _n :% 1) ->
|
||||
Right $ fixedToInteger places (i, f)
|
||||
(Just (i, f), _n :% _d) ->
|
||||
Left $ "Using more than the available decimal places (" <> show places <> "). Would round to " <> show i <> "." <> show f
|
||||
_ -> Left "Some error occurred while getting number"
|
||||
|
||||
discreteExp :: String -> Q Exp
|
||||
discreteExp s = case parseDiscreteRatioExp s of
|
||||
Nothing ->
|
||||
fail $ "Input malformed. Got: " <> s
|
||||
Just (num, mc) -> do
|
||||
mcName <-
|
||||
lookupTypeName mc >>= \case
|
||||
Nothing -> fail $ "MoneyClass with the name " <> show mc <> " is not in scope."
|
||||
Just v -> pure v
|
||||
reified <- reify mcName
|
||||
case reified of
|
||||
TyConI (TySynD tyName [] (AppT (AppT (AppT (PromotedTupleT 3) (LitT (StrTyLit _))) (LitT _)) (LitT (NumTyLit n)))) ->
|
||||
case safeIntegerUpcast n num of
|
||||
Right i ->
|
||||
pure $ AppE (AppTypeE (VarE 'discreteConstant) (ConT tyName)) (LitE (IntegerL i))
|
||||
Left e -> fail e
|
||||
ty' -> fail $ "Could not reify type, got: " <> show ty'
|
||||
|
||||
parseDiscreteRatioExp :: String -> Maybe (Number, String)
|
||||
parseDiscreteRatioExp s =
|
||||
let p = skipSpaces *> ((,) <$> readPrec_to_P lexP 0 <* skipSpaces <*> readPrec_to_P lexP 0) <* skipSpaces
|
||||
in case readP_to_S p s of
|
||||
[((Number n, Ident i), "")] -> Just (n, i)
|
||||
_ -> Nothing
|
||||
|
||||
errorDiscretePat :: String -> Q Pat
|
||||
errorDiscretePat _ = fail "Cannot use 'discrete' in a pattern context."
|
||||
|
||||
errorDiscreteType :: String -> Q TH.Type
|
||||
errorDiscreteType _ = fail "Cannot use 'discrete' in a type context."
|
||||
|
||||
errorDiscreteDiscretelaration :: String -> Q [Dec]
|
||||
errorDiscreteDiscretelaration _ = fail "Cannot use 'discrete' in a declaration context."
|
||||
|
|
@ -20,13 +20,7 @@ module Agora.Stake (
|
|||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.String (IsString (fromString))
|
||||
import GHC.Generics qualified as GHC
|
||||
import GHC.TypeLits (
|
||||
KnownSymbol,
|
||||
symbolVal,
|
||||
)
|
||||
import Generics.SOP (Generic, I (I))
|
||||
import Prelude
|
||||
|
||||
|
|
@ -59,7 +53,9 @@ import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
import Agora.SafeMoney (
|
||||
MoneyClass,
|
||||
AssetClassRef (..),
|
||||
Discrete,
|
||||
GTTag,
|
||||
PDiscrete,
|
||||
paddDiscrete,
|
||||
pdiscreteValue,
|
||||
|
|
@ -71,6 +67,7 @@ import Agora.Utils (
|
|||
anyOutput,
|
||||
paddValue,
|
||||
passert,
|
||||
passetClassValueOf',
|
||||
pfindTxInByTxOutRef,
|
||||
pgeqByClass,
|
||||
pgeqByClass',
|
||||
|
|
@ -84,12 +81,15 @@ import Agora.Utils (
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Parameters for creating Stake scripts.
|
||||
data Stake (gt :: MoneyClass) = Stake
|
||||
newtype Stake = Stake
|
||||
{ gtClassRef :: AssetClassRef GTTag
|
||||
-- ^ Used when inlining the AssetClass of a 'PDiscrete' in the script code.
|
||||
}
|
||||
|
||||
-- | Plutarch-level redeemer for Stake scripts.
|
||||
data PStakeRedeemer (gt :: MoneyClass) (s :: S)
|
||||
data PStakeRedeemer (s :: S)
|
||||
= -- | Deposit or withdraw a discrete amount of the staked governance token.
|
||||
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete gt]))
|
||||
PDepositWithdraw (Term s (PDataRecord '["delta" ':= PDiscrete GTTag]))
|
||||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
PDestroy (Term s (PDataRecord '[]))
|
||||
deriving stock (GHC.Generic)
|
||||
|
|
@ -97,18 +97,12 @@ data PStakeRedeemer (gt :: MoneyClass) (s :: S)
|
|||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData)
|
||||
via PIsDataReprInstances (PStakeRedeemer gt)
|
||||
|
||||
-- FIXME: 'StakeRedeemer' and 'StakeDatum' are stripped of their
|
||||
-- typesafe `PDiscrete` equivalent due to issues with `makeIsDataIndexed`
|
||||
-- when using the kind @gt :: MoneyClass@. This ought to be fixed with
|
||||
-- a future patch in Plutarch upstream. For now, we will deal with lower
|
||||
-- type safety off-chain.
|
||||
via PIsDataReprInstances PStakeRedeemer
|
||||
|
||||
-- | Haskell-level redeemer for Stake scripts.
|
||||
data StakeRedeemer
|
||||
= -- | Deposit or withdraw a discrete amount of the staked governance token.
|
||||
DepositWithdraw Integer
|
||||
DepositWithdraw (Discrete GTTag)
|
||||
| -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets.
|
||||
Destroy
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
|
@ -116,21 +110,20 @@ data StakeRedeemer
|
|||
PlutusTx.makeIsDataIndexed ''StakeRedeemer [('DepositWithdraw, 0), ('Destroy, 1)]
|
||||
|
||||
-- | Plutarch-level datum for Stake scripts.
|
||||
newtype PStakeDatum (gt :: MoneyClass) (s :: S) = PStakeDatum
|
||||
newtype PStakeDatum (s :: S) = PStakeDatum
|
||||
{ getStakeDatum ::
|
||||
Term s (PDataRecord '["stakedAmount" ':= PDiscrete gt, "owner" ':= PPubKeyHash])
|
||||
Term s (PDataRecord '["stakedAmount" ':= PDiscrete GTTag, "owner" ':= PPubKeyHash])
|
||||
}
|
||||
deriving stock (GHC.Generic)
|
||||
deriving anyclass (Generic)
|
||||
deriving anyclass (PIsDataRepr)
|
||||
deriving
|
||||
(PlutusType, PIsData, PDataFields)
|
||||
via (PIsDataReprInstances (PStakeDatum gt))
|
||||
via (PIsDataReprInstances PStakeDatum)
|
||||
|
||||
-- | Haskell-level datum for Stake scripts.
|
||||
data StakeDatum = StakeDatum
|
||||
{ -- FIXME: This needs to be gt
|
||||
stakedAmount :: Integer
|
||||
{ stakedAmount :: Discrete GTTag
|
||||
, owner :: PubKeyHash
|
||||
}
|
||||
deriving stock (Show, GHC.Generic)
|
||||
|
|
@ -154,14 +147,10 @@ PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
|
|||
|
||||
-- | Policy for Stake state threads.
|
||||
stakePolicy ::
|
||||
forall (gt :: MoneyClass) ac n scale s.
|
||||
( KnownSymbol ac
|
||||
, KnownSymbol n
|
||||
, gt ~ '(ac, n, scale)
|
||||
) =>
|
||||
Stake gt ->
|
||||
forall (s :: S).
|
||||
Stake ->
|
||||
Term s PMintingPolicy
|
||||
stakePolicy _stake =
|
||||
stakePolicy stake =
|
||||
plam $ \_redeemer ctx' -> P.do
|
||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||
txInfo' <- plet ctx.txInfo
|
||||
|
|
@ -180,7 +169,7 @@ stakePolicy _stake =
|
|||
mintedST #== -1
|
||||
|
||||
passert "An unlocked input existed containing an ST" $
|
||||
anyInput @(PStakeDatum gt) # pfromData txInfo'
|
||||
anyInput @PStakeDatum # pfromData txInfo'
|
||||
#$ plam
|
||||
$ \value _ stakeDatum' -> P.do
|
||||
let hasST = psymbolValueOf # ownSymbol # value #== 1
|
||||
|
|
@ -197,7 +186,7 @@ stakePolicy _stake =
|
|||
mintedST #== 1
|
||||
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @(PStakeDatum gt) # pfromData txInfo'
|
||||
anyOutput @PStakeDatum # pfromData txInfo'
|
||||
#$ plam
|
||||
$ \value address stakeDatum' -> P.do
|
||||
let cred = pfield @"credential" # address
|
||||
|
|
@ -220,7 +209,7 @@ stakePolicy _stake =
|
|||
# 1
|
||||
let expectedValue =
|
||||
paddValue
|
||||
# (pdiscreteValue # stakeDatum.stakedAmount)
|
||||
# (pdiscreteValue stake.gtClassRef # stakeDatum.stakedAmount)
|
||||
# stValue
|
||||
let ownerSignsTransaction =
|
||||
ptxSignedBy
|
||||
|
|
@ -234,12 +223,7 @@ stakePolicy _stake =
|
|||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass'
|
||||
( AssetClass
|
||||
( fromString . symbolVal $ Proxy @ac
|
||||
, fromString . symbolVal $ Proxy @n
|
||||
)
|
||||
)
|
||||
, pgeqByClass' stake.gtClassRef.getAssetClass
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqByClass
|
||||
|
|
@ -259,12 +243,8 @@ stakePolicy _stake =
|
|||
|
||||
-- | Validator intended for Stake UTXOs to live in.
|
||||
stakeValidator ::
|
||||
forall (gt :: MoneyClass) ac n scale s.
|
||||
( KnownSymbol ac
|
||||
, KnownSymbol n
|
||||
, gt ~ '(ac, n, scale)
|
||||
) =>
|
||||
Stake gt ->
|
||||
forall (s :: S).
|
||||
Stake ->
|
||||
Term s PValidator
|
||||
stakeValidator stake =
|
||||
plam $ \datum redeemer ctx' -> P.do
|
||||
|
|
@ -273,9 +253,9 @@ stakeValidator stake =
|
|||
txInfo <- pletFields @'["mint", "inputs", "outputs"] txInfo'
|
||||
|
||||
-- Coercion is safe in that if coercion fails we crash hard.
|
||||
let stakeRedeemer :: Term _ (PStakeRedeemer gt)
|
||||
let stakeRedeemer :: Term _ PStakeRedeemer
|
||||
stakeRedeemer = pfromData $ punsafeCoerce redeemer
|
||||
stakeDatum' :: Term _ (PStakeDatum gt)
|
||||
stakeDatum' :: Term _ PStakeDatum
|
||||
stakeDatum' = pfromData $ punsafeCoerce datum
|
||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||
|
||||
|
|
@ -310,7 +290,7 @@ stakeValidator stake =
|
|||
"Owner signs this transaction"
|
||||
ownerSignsTransaction
|
||||
passert "A UTXO must exist with the correct output" $
|
||||
anyOutput @(PStakeDatum gt) # txInfo'
|
||||
anyOutput @PStakeDatum # txInfo'
|
||||
#$ plam
|
||||
$ \value address newStakeDatum' -> P.do
|
||||
newStakeDatum <- pletFields @'["owner", "stakedAmount"] newStakeDatum'
|
||||
|
|
@ -325,7 +305,10 @@ stakeValidator stake =
|
|||
-- do we need to check this, really?
|
||||
pgeqDiscrete # (pfromData newStakeDatum.stakedAmount) # pzeroDiscrete
|
||||
]
|
||||
let expectedValue = paddValue # continuingValue # (pdiscreteValue # delta)
|
||||
let expectedValue = paddValue # continuingValue # (pdiscreteValue stake.gtClassRef # delta)
|
||||
|
||||
ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # value)
|
||||
ptrace (pshow $ passetClassValueOf' stake.gtClassRef.getAssetClass # expectedValue)
|
||||
|
||||
-- TODO: Same as above. This is quite inefficient now, as it does two lookups
|
||||
-- instead of a more efficient single pass,
|
||||
|
|
@ -334,12 +317,7 @@ stakeValidator stake =
|
|||
foldr1
|
||||
(#&&)
|
||||
[ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
|
||||
, pgeqByClass'
|
||||
( AssetClass
|
||||
( fromString . symbolVal $ Proxy @ac
|
||||
, fromString . symbolVal $ Proxy @n
|
||||
)
|
||||
)
|
||||
, pgeqByClass' stake.gtClassRef.getAssetClass
|
||||
# value
|
||||
# expectedValue
|
||||
, pgeqBySymbol
|
||||
|
|
@ -360,7 +338,7 @@ stakeValidator stake =
|
|||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
|
||||
stakeLocked :: forall (gt :: MoneyClass) s. Term s (PStakeDatum gt :--> PBool)
|
||||
stakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
|
||||
stakeLocked = phoistAcyclic $
|
||||
plam $ \_stakeDatum ->
|
||||
-- TODO: when we extend this to support proposals, this will need to do something
|
||||
|
|
|
|||
|
|
@ -183,21 +183,21 @@ passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
|
|||
passetClassValueOf' (AssetClass (sym, token)) =
|
||||
passetClassValueOf # pconstant sym # pconstant token
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular AssetClass
|
||||
-- | Return '>=' on two values comparing by only a particular AssetClass.
|
||||
pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool)
|
||||
pgeqByClass =
|
||||
phoistAcyclic $
|
||||
plam $ \cs tn a b ->
|
||||
passetClassValueOf # cs # tn # b #<= passetClassValueOf # cs # tn # a
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular CurrencySymbol
|
||||
-- | Return '>=' on two values comparing by only a particular CurrencySymbol.
|
||||
pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool)
|
||||
pgeqBySymbol =
|
||||
phoistAcyclic $
|
||||
plam $ \cs a b ->
|
||||
psymbolValueOf # cs # b #<= psymbolValueOf # cs # a
|
||||
|
||||
-- | Return '>=' on two values comparing by only a particular Haskell-level AssetClass
|
||||
-- | Return '>=' on two values comparing by only a particular Haskell-level AssetClass.
|
||||
pgeqByClass' :: AssetClass -> Term s (PValue :--> PValue :--> PBool)
|
||||
pgeqByClass' ac =
|
||||
phoistAcyclic $
|
||||
|
|
@ -233,7 +233,7 @@ pmapUnionWith = phoistAcyclic $
|
|||
# ys
|
||||
pcon (PMap $ pconcat # ls # rs)
|
||||
|
||||
-- | Add two 'PValue's together
|
||||
-- | Add two 'PValue's together.
|
||||
paddValue :: forall s. Term s (PValue :--> PValue :--> PValue)
|
||||
paddValue = phoistAcyclic $
|
||||
plam $ \a' b' -> P.do
|
||||
|
|
|
|||
|
|
@ -1,11 +0,0 @@
|
|||
{- |
|
||||
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
|
||||
|
|
@ -11,7 +11,8 @@ module PPrelude (
|
|||
module Plutarch,
|
||||
) where
|
||||
|
||||
-- These are not exported by Plutarch.Prelude, for some reason. Maybe we can 'fix' this upstream?
|
||||
import Plutarch (ClosedTerm, compile)
|
||||
-- NOTE: These are not exported by Plutarch.Prelude, for some reason.
|
||||
-- Maybe we can 'fix' this upstream?
|
||||
import Plutarch (ClosedTerm, POpaque, compile)
|
||||
import Plutarch.Prelude
|
||||
import Prelude
|
||||
|
|
|
|||
120
flake.lock
generated
120
flake.lock
generated
|
|
@ -70,7 +70,7 @@
|
|||
"flake-compat-ci": "flake-compat-ci",
|
||||
"haskell-nix": "haskell-nix",
|
||||
"nixpkgs": [
|
||||
"apropos",
|
||||
"plutarch",
|
||||
"haskell-nix",
|
||||
"nixpkgs-unstable"
|
||||
]
|
||||
|
|
@ -155,10 +155,10 @@
|
|||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1603716527,
|
||||
"narHash": "sha256-X0TFfdD4KZpwl0Zr6x+PLxUt/VyKQfX7ylXHdmZIL+w=",
|
||||
"narHash": "sha256-sDbrmur9Zfp4mPKohCD8IDZfXJ0Tjxpmr2R+kg5PpSY=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "48bf10787e27364730dd37a42b603cee8d6af7ee",
|
||||
"rev": "94aaa8e4720081f9c75497e2735b90f6a819b08e",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -205,11 +205,11 @@
|
|||
"cabal-34_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1640353650,
|
||||
"narHash": "sha256-N1t6M3/wqj90AEdRkeC8i923gQYUpzSr8b40qVOZ1Rk=",
|
||||
"lastModified": 1622475795,
|
||||
"narHash": "sha256-chwTL304Cav+7p38d9mcb+egABWmxo2Aq+xgVBgEb/U=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "942639c18c0cd8ec53e0a6f8d120091af35312cd",
|
||||
"rev": "b086c1995cdd616fc8d91f46a21e905cc50a1049",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -254,23 +254,6 @@
|
|||
}
|
||||
},
|
||||
"cabal-36_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1641652457,
|
||||
"narHash": "sha256-BlFPKP4C4HRUJeAbdembX1Rms1LD380q9s0qVDeoAak=",
|
||||
"owner": "haskell",
|
||||
"repo": "cabal",
|
||||
"rev": "f27667f8ec360c475027dcaee0138c937477b070",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "3.6",
|
||||
"repo": "cabal",
|
||||
"type": "github"
|
||||
}
|
||||
},
|
||||
"cabal-36_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1640163203,
|
||||
|
|
@ -577,11 +560,11 @@
|
|||
},
|
||||
"flake-utils_2": {
|
||||
"locked": {
|
||||
"lastModified": 1644229661,
|
||||
"narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
|
||||
"lastModified": 1623875721,
|
||||
"narHash": "sha256-A8BU7bjS5GirpAUv4QA+QnJ4CceLHkcXdRp4xITDB0s=",
|
||||
"owner": "numtide",
|
||||
"repo": "flake-utils",
|
||||
"rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
|
||||
"rev": "f7e004a55b120c02ecb6219596820fcd32ca8772",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -741,11 +724,11 @@
|
|||
"hackage-nix": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1644369434,
|
||||
"narHash": "sha256-WqU6f1OhSM0UHXFW8Mhhvhz0tcij+NQVtmb6sW4RiFw=",
|
||||
"lastModified": 1637291070,
|
||||
"narHash": "sha256-hTX2Xo36i9MR6PNwA/89C8daKjxmx5ZS5lwR2Cbp8Yo=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"rev": "644a0d702abf84cdec62f4e620ff1034000e6146",
|
||||
"rev": "6ea4ad5f4a5e2303cd64974329ba90ccc410a012",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -773,11 +756,11 @@
|
|||
"hackage_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1646270198,
|
||||
"narHash": "sha256-SakG546Zr9RuNPs5mhtT7CYPpvEDMGrWisWK/VpCvr0=",
|
||||
"lastModified": 1639357972,
|
||||
"narHash": "sha256-NvVn00YOYZMqDUSiBbghJk/rm/nJItBEUJulWRGTgvk=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "hackage.nix",
|
||||
"rev": "4cf90b36955597d0151940eabfb1b61a8ec42256",
|
||||
"rev": "54adf6e47e20831d9c49a2b62e12f7f218fd7752",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -805,16 +788,16 @@
|
|||
"haskell-language-server": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1643835246,
|
||||
"narHash": "sha256-5LQHcQmi3mUGRgJu+X/m3jeM3kdkYjLD+KwgnxBlbeU=",
|
||||
"lastModified": 1638136578,
|
||||
"narHash": "sha256-Reo9BQ12O+OX7tuRfaDPZPBpJW4jnxZetm63BxYncoM=",
|
||||
"owner": "haskell",
|
||||
"repo": "haskell-language-server",
|
||||
"rev": "024ddc8b3904f8b8e8fe67ba6b9ebd8a4bd7ce76",
|
||||
"rev": "745ef26f406dbdd5e4a538585f8519af9f1ccb09",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
"owner": "haskell",
|
||||
"ref": "1.6.1.1",
|
||||
"ref": "1.5.1",
|
||||
"repo": "haskell-language-server",
|
||||
"type": "github"
|
||||
}
|
||||
|
|
@ -895,7 +878,6 @@
|
|||
"HTTP": "HTTP_2",
|
||||
"cabal-32": "cabal-32_2",
|
||||
"cabal-34": "cabal-34_2",
|
||||
"cabal-36": "cabal-36_2",
|
||||
"cardano-shell": "cardano-shell_2",
|
||||
"flake-utils": "flake-utils_2",
|
||||
"ghc-8.6.5-iohk": "ghc-8.6.5-iohk_2",
|
||||
|
|
@ -915,11 +897,11 @@
|
|||
"stackage": "stackage_2"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1646278384,
|
||||
"narHash": "sha256-Gv1Ws3vAojjvjATcsvwAOTuOhzpxwt6tBci7EBaXxU4=",
|
||||
"lastModified": 1639371915,
|
||||
"narHash": "sha256-i5kW3hPptzXwzkpI2FAkfdDA/9QEDl/9mrwwoeBxDJg=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "7e06e14ae1b894445254fe41288bfa7dd4ccbc6f",
|
||||
"rev": "e95a1f0dacbc64603c31d11e36e4ba1af8f0eb43",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -931,11 +913,11 @@
|
|||
"haskell-nix_3": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1646278384,
|
||||
"narHash": "sha256-Gv1Ws3vAojjvjATcsvwAOTuOhzpxwt6tBci7EBaXxU4=",
|
||||
"lastModified": 1629380841,
|
||||
"narHash": "sha256-gWOWCfX7IgVSvMMYN6rBGK6EA0pk6pmYguXzMvGte+Q=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "haskell.nix",
|
||||
"rev": "7e06e14ae1b894445254fe41288bfa7dd4ccbc6f",
|
||||
"rev": "7215f083b37741446aa325b20c8ba9f9f76015eb",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -949,7 +931,7 @@
|
|||
"HTTP": "HTTP_3",
|
||||
"cabal-32": "cabal-32_3",
|
||||
"cabal-34": "cabal-34_3",
|
||||
"cabal-36": "cabal-36_3",
|
||||
"cabal-36": "cabal-36_2",
|
||||
"cardano-shell": "cardano-shell_3",
|
||||
"flake-utils": "flake-utils_3",
|
||||
"ghc-8.6.5-iohk": "ghc-8.6.5-iohk_3",
|
||||
|
|
@ -957,8 +939,6 @@
|
|||
"hpc-coveralls": "hpc-coveralls_3",
|
||||
"nix-tools": "nix-tools_3",
|
||||
"nixpkgs": [
|
||||
"plutarch",
|
||||
"haskell-nix",
|
||||
"nixpkgs-2111"
|
||||
],
|
||||
"nixpkgs-2003": "nixpkgs-2003_3",
|
||||
|
|
@ -1193,11 +1173,11 @@
|
|||
"nix-tools_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1644395812,
|
||||
"narHash": "sha256-BVFk/BEsTLq5MMZvdy3ZYHKfaS3dHrsKh4+tb5t5b58=",
|
||||
"lastModified": 1636018067,
|
||||
"narHash": "sha256-ng306fkuwr6V/malWtt3979iAC4yMVDDH2ViwYB6sQE=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "nix-tools",
|
||||
"rev": "d847c63b99bbec78bf83be2a61dc9f09b8a9ccc1",
|
||||
"rev": "ed5bd7215292deba55d6ab7a4e8c21f8b1564dda",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1257,11 +1237,11 @@
|
|||
"nixpkgs": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1645493675,
|
||||
"narHash": "sha256-9xundbZQbhFodsQRh6QMN1GeSXfo3y/5NL0CZcJULz0=",
|
||||
"lastModified": 1628785280,
|
||||
"narHash": "sha256-2B5eMrEr6O8ff2aQNeVxTB+9WrGE80OB4+oM6T7fOcc=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "74b10859829153d5c5d50f7c77b86763759e8654",
|
||||
"rev": "6525bbc06a39f26750ad8ee0d40000ddfdc24acb",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1337,11 +1317,11 @@
|
|||
},
|
||||
"nixpkgs-2105_2": {
|
||||
"locked": {
|
||||
"lastModified": 1642244250,
|
||||
"narHash": "sha256-vWpUEqQdVP4srj+/YLJRTN9vjpTs4je0cdWKXPbDItc=",
|
||||
"lastModified": 1639202042,
|
||||
"narHash": "sha256-xEMgCsIcDUQ0kw9xvqU0wObns580kpdcr1ACz83+gHs=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0fd9ee1aa36ce865ad273f4f07fdc093adeb5c00",
|
||||
"rev": "499ca2a9f6463ce119e40361f4329afa921a1d13",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1385,11 +1365,11 @@
|
|||
},
|
||||
"nixpkgs-2111_2": {
|
||||
"locked": {
|
||||
"lastModified": 1644510859,
|
||||
"narHash": "sha256-xjpVvL5ecbyi0vxtVl/Fh9bwGlMbw3S06zE5nUzFB8A=",
|
||||
"lastModified": 1639213685,
|
||||
"narHash": "sha256-Evuobw7o9uVjAZuwz06Al0fOWZ5JMKOktgXR0XgWBtg=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "0d1d5d7e3679fec9d07f2eb804d9f9fdb98378d3",
|
||||
"rev": "453bcb8380fd1777348245b3c44ce2a2b93b2e2d",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1401,11 +1381,11 @@
|
|||
},
|
||||
"nixpkgs-2111_3": {
|
||||
"locked": {
|
||||
"lastModified": 1647902355,
|
||||
"narHash": "sha256-SySJ8IRaogpc/BPOkysA+kzq9URvXthoeKIemaTKCiM=",
|
||||
"lastModified": 1648420413,
|
||||
"narHash": "sha256-AHejj7EsbTt+CMOoy15wwkFsFNmx8oinGgDZR22lS6g=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "31aa631dbc496500efd2507baaed39626f6650f2",
|
||||
"rev": "d6778e0b5d608eb6738af2a64e26d99cdc5b9e86",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1481,11 +1461,11 @@
|
|||
},
|
||||
"nixpkgs-unstable_2": {
|
||||
"locked": {
|
||||
"lastModified": 1644486793,
|
||||
"narHash": "sha256-EeijR4guVHgVv+JpOX3cQO+1XdrkJfGmiJ9XVsVU530=",
|
||||
"lastModified": 1639239143,
|
||||
"narHash": "sha256-9fFMUs6m3/4ZMflSqRgO4iEkBtFBnDyLWa3AB2tOvfs=",
|
||||
"owner": "NixOS",
|
||||
"repo": "nixpkgs",
|
||||
"rev": "1882c6b7368fd284ad01b0a5b5601ef136321292",
|
||||
"rev": "e6df26a654b7fdd59a068c57001eab5736b1363c",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1669,11 +1649,11 @@
|
|||
"stackage-nix": "stackage-nix"
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1646401716,
|
||||
"narHash": "sha256-Xh4m6NVgxhtJZPW+/TH0KncginXLORO6EAN/ulitlrw=",
|
||||
"lastModified": 1639153959,
|
||||
"narHash": "sha256-tz8wEV5oO2yu2WFl3+wAPHedJJUP/NMFYgfcsbcyji4=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "plutus",
|
||||
"rev": "73e4bbfc32ea233ba679d3f558a95adf8513a9d7",
|
||||
"rev": "da4f85cdd2a3a261ce540e8dc51d2a3c5fa89ed2",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
@ -1908,11 +1888,11 @@
|
|||
"stackage_2": {
|
||||
"flake": false,
|
||||
"locked": {
|
||||
"lastModified": 1646270328,
|
||||
"narHash": "sha256-WFzBTbZW9zKnZtHLBLGui9F1tBDKX7ixBtaQOG5SK/M=",
|
||||
"lastModified": 1639185224,
|
||||
"narHash": "sha256-ZBL0Lvqq8/Iwl8F5sT2N9J8+HTh0OY+09LkkUVtuUtY=",
|
||||
"owner": "input-output-hk",
|
||||
"repo": "stackage.nix",
|
||||
"rev": "b3171527569b52b3924d8e70e0aed753d3f55cc4",
|
||||
"rev": "14819f5c85a92e5fb6e322cc809c803fa6419bd4",
|
||||
"type": "github"
|
||||
},
|
||||
"original": {
|
||||
|
|
|
|||
13
flake.nix
13
flake.nix
|
|
@ -11,18 +11,19 @@
|
|||
inputs.plutarch.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
|
||||
# Follows jhodgdev's forks of apropos and apropos-tx, as these
|
||||
# are not constrained to `base ^>= 4.14`. Once these are merged
|
||||
# to their respective master branches, we should change the
|
||||
# inputs to follow a commit on those master branches. For more
|
||||
# info, see: https://github.com/mlabs-haskell/apropos-tx/pull/37
|
||||
# Follows jhodgdev's forks of apropos and apropos-tx, as these
|
||||
# are not constrained to `base ^>= 4.14`. Once these are merged
|
||||
# to their respective master branches, we should change the
|
||||
# inputs to follow a commit on those master branches. For more
|
||||
# info, see: https://github.com/mlabs-haskell/apropos-tx/pull/37
|
||||
inputs.apropos-tx.url =
|
||||
"github:jhodgdev/apropos-tx?rev=582496d0dfb88ce007bb0d2a2dcbc72ea0bb1cd1";
|
||||
inputs.apropos-tx.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
inputs.apropos.url =
|
||||
"github:jhodgdev/apropos?rev=c6c580aeab8b5c2a6512a49823dd17936e87b70a";
|
||||
|
||||
inputs.apropos.inputs.nixpkgs.follows =
|
||||
"plutarch/haskell-nix/nixpkgs-unstable";
|
||||
|
||||
outputs = inputs@{ self, nixpkgs, haskell-nix, plutarch, ... }:
|
||||
let
|
||||
|
|
|
|||
2
hie.yaml
2
hie.yaml
|
|
@ -1,6 +1,6 @@
|
|||
cradle:
|
||||
cabal:
|
||||
- path: "./agora-src"
|
||||
- path: "./agora"
|
||||
component: "lib:agora"
|
||||
- path: "./agora-bench"
|
||||
component: "benchmark:agora-bench"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue