Sulkta-OSS/agora
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'master' of github.com:Liqwid-Labs/agora into jhodgdev/fix-apropos-dep

Browse source
This commit is contained in:
Jack Hodgkinson 2022-04-01 10:51:51 +01:00
commit 1f68089bdc
19 changed files with 443 additions and 2252 deletions
Download patch file Download diff file Expand all files Collapse all files

1
Makefile
View file

@ -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 &

2
agora-test/Spec.hs
View file

@ -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 $

8
agora-test/Spec/Model/MultiSig.hs
View file

@ -53,7 +53,7 @@ import Apropos (
import Apropos.Gen (Gen, choice, int, linear, list)
import Apropos.LogicalModel (Enumerable)
import Apropos.LogicalModel.Enumerable (Enumerable (enumerated))
import Apropos.Script (HasScriptRunner (expect, runScriptTestsWhere, script))
import Apropos.Script (ScriptModel (expect, runScriptTestsWhere, script))
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (fromGroup)
@ -157,7 +157,7 @@ instance HasParameterisedGenerator MultiSigProp MultiSigModel where
-- Return the generated model.
pure (MultiSigModel msig ctx)
instance HasScriptRunner MultiSigProp MultiSigModel where
instance ScriptModel MultiSigProp MultiSigModel where
-- When the script runs, we want the model to meet the minimum signatures.
expect :: (MultiSigModel :+ MultiSigProp) -> Formula MultiSigProp
expect Apropos = Var MeetsMinSigs
@ -171,7 +171,7 @@ instance HasScriptRunner 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 'HasScriptRunner' instance of 'MultiSigModel'
-- | Tests for the 'ScriptModel' instance of 'MultiSigModel'.
plutarchTests :: TestTree
plutarchTests =
testGroup "plutarchTests" $

30
agora-test/Spec/Sample/Stake.hs
View file

@ -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)
}
]

8
agora-test/Spec/Stake.hs
View file

@ -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})
]
]

7
agora.cabal
View file

@ -96,6 +96,7 @@ common deps
, generics-sop
, plutarch
, plutarch-extra
, plutarch-numeric
, plutus-core
, plutus-ledger-api
, plutus-tx
@ -108,6 +109,7 @@ common deps
common test-deps
build-depends:
, apropos
, apropos-tx
, QuickCheck
, quickcheck-instances
@ -121,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
View 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
View 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

4
agora/Agora/MultiSig.hs
View file

@ -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
View 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)

140
agora/Agora/SafeMoney.hs
View file

@ -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

96
agora/Agora/SafeMoney/QQ.hs
View file

@ -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."

90
agora/Agora/Stake.hs
View file

@ -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

8
agora/Agora/Utils.hs
View file

@ -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

11
agora/Agora/Voting.hs
View file

@ -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

5
agora/PPrelude.hs
View file

@ -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

1994
flake.lock generated
View file

File diff suppressed because it is too large Load diff

11
flake.nix
View file

@ -11,11 +11,19 @@
inputs.plutarch.inputs.nixpkgs.follows =
"plutarch/haskell-nix/nixpkgs-unstable";
# https://github.com/mlabs-haskell/apropos-tx/pull/28
# 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=4eca3fac23c339caee04ea6176e641a4b3857a25";
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";
inputs.apropos.url =
"github:mlabs-haskell/apropos?rev=3734bb3baa297ed990725a5ef14efcbb6a1c1c23";
@ -93,6 +101,7 @@
ps.plutarch-extra
ps.plutarch-numeric
ps.plutarch-test
ps.apropos
];
};
};

2
hie.yaml
View file

@ -1,6 +1,6 @@
cradle:
cabal:
- path: "./agora-src"
- path: "./agora"
component: "lib:agora"
- path: "./agora-bench"
component: "benchmark:agora-bench"