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

flake: bump plutarch, fix resulting issues

Browse source 
Collection of things fixed:
- `agora-test`: Fix compile resulting from some changes to hackage.
- `agora-benchmark`: Switched to `plutarch`-style `evalScript`.
- CI: Ported over new flake changes.

This is quite a mess.
This commit is contained in:
Emily Martins 2022-06-02 20:30:28 +02:00
parent 8e71ecbdfd
commit ad9da8e6b3
49 changed files with 3487 additions and 3829 deletions
Download patch file Download diff file Expand all files Collapse all files

19
agora-bench/Bench.hs
View file

@ -7,18 +7,16 @@ import Data.ByteString.Lazy qualified as LBS
import Data.ByteString.Short qualified as SBS
import Data.Csv (DefaultOrdered, ToNamedRecord, header, headerOrder, namedRecord, toNamedRecord, (.=))
import Data.List (intercalate)
import Data.Maybe (fromJust)
import Data.Text (Text, pack)
import GHC.Generics (Generic)
import Plutus.V1.Ledger.Api (
import Plutarch.Evaluate (evalScript)
import PlutusLedgerApi.V1 (
ExBudget (ExBudget),
ExCPU (..),
ExMemory (..),
Script,
)
import Plutus.V1.Ledger.Api qualified as Plutus
import Prettyprinter (Pretty (pretty), indent, vsep)
import Test.Specification (
Specification (Specification),
SpecificationExpectation (Success),
@ -67,18 +65,9 @@ instance DefaultOrdered Benchmark where
benchmarkScript :: String -> Script -> Benchmark
benchmarkScript name script = Benchmark (pack name) cpu mem size
where
(ExBudget cpu mem) = evalScriptCounting . serialiseScriptShort $ script
size = SBS.length . SBS.toShort . LBS.toStrict . serialise $ script
(_res, ExBudget cpu mem, _traces) = evalScript script
serialiseScriptShort :: Script -> SBS.ShortByteString
serialiseScriptShort = SBS.toShort . LBS.toStrict . serialise -- Using `flat` here breaks `evalScriptCounting`
evalScriptCounting :: Plutus.SerializedScript -> Plutus.ExBudget
evalScriptCounting script =
let costModel = fromJust Plutus.defaultCostModelParams
(_logout, e) = Plutus.evaluateScriptCounting Plutus.Verbose costModel script []
in case e of
Left evalError -> error ("Eval Error: " <> show evalError)
Right exbudget -> exbudget
size = SBS.length . SBS.toShort . LBS.toStrict . serialise $ script
specificationTreeToBenchmarks :: SpecificationTree -> [Benchmark]
specificationTreeToBenchmarks = go []

41
agora-purescript-bridge/AgoraTypes.hs
View file

@ -2,6 +2,7 @@ module AgoraTypes (agoraTypes) where
--------------------------------------------------------------------------------
import Data.Proxy (Proxy (..))
import Language.PureScript.Bridge (
Language (Haskell),
SumType,
@ -24,30 +25,30 @@ import Agora.Treasury qualified as Treasury
agoraTypes :: [SumType 'Haskell]
agoraTypes =
[ -- Proposal
mkSumType @Proposal.ProposalId
, mkSumType @Proposal.ResultTag
, mkSumType @Proposal.ProposalStatus
, mkSumType @Proposal.ProposalThresholds
, mkSumType @Proposal.ProposalVotes
, mkSumType @Proposal.ProposalDatum
, mkSumType @Proposal.ProposalRedeemer
, mkSumType @Proposal.Proposal
mkSumType (Proxy @Proposal.ProposalId)
, mkSumType (Proxy @Proposal.ResultTag)
, mkSumType (Proxy @Proposal.ProposalStatus)
, mkSumType (Proxy @Proposal.ProposalThresholds)
, mkSumType (Proxy @Proposal.ProposalVotes)
, mkSumType (Proxy @Proposal.ProposalDatum)
, mkSumType (Proxy @Proposal.ProposalRedeemer)
, mkSumType (Proxy @Proposal.Proposal)
, -- Governor
mkSumType @Governor.GovernorDatum
, mkSumType @Governor.GovernorRedeemer
, mkSumType @Governor.Governor
mkSumType (Proxy @Governor.GovernorDatum)
, mkSumType (Proxy @Governor.GovernorRedeemer)
, mkSumType (Proxy @Governor.Governor)
, -- MultiSig
mkSumType @MultiSig.MultiSig
mkSumType (Proxy @MultiSig.MultiSig)
, -- Stake
mkSumType @Stake.Stake
, mkSumType @Stake.ProposalLock
, mkSumType @Stake.StakeRedeemer
, mkSumType @Stake.StakeDatum
mkSumType (Proxy @Stake.Stake)
, mkSumType (Proxy @Stake.ProposalLock)
, mkSumType (Proxy @Stake.StakeRedeemer)
, mkSumType (Proxy @Stake.StakeDatum)
, -- Treasury
mkSumType @Treasury.TreasuryRedeemer
mkSumType (Proxy @Treasury.TreasuryRedeemer)
, -- AuthorityToken
mkSumType @AuthorityToken.AuthorityToken
mkSumType (Proxy @AuthorityToken.AuthorityToken)
, -- Effects
mkSumType @TreasuryWithdrawalEffect.TreasuryWithdrawalDatum
, mkSumType @GovernorMutation.MutateGovernorDatum
mkSumType (Proxy @TreasuryWithdrawalEffect.TreasuryWithdrawalDatum)
, mkSumType (Proxy @GovernorMutation.MutateGovernorDatum)
]

2
agora-purescript-bridge/src/Agora/AuthorityToken.purs
View file

@ -9,7 +9,7 @@ import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record (prop)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Plutus.V1.Ledger.Value (AssetClass)
import PlutusLedgerApi.V1.Value (AssetClass)
import Type.Proxy (Proxy(Proxy))
newtype AuthorityToken = AuthorityToken { authority :: AssetClass }

2
agora-purescript-bridge/src/Agora/Effect/GovernorMutation.purs
View file

@ -10,7 +10,7 @@ import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record (prop)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Plutus.V1.Ledger.Tx (TxOutRef)
import PlutusLedgerApi.V1.Tx (TxOutRef)
import Type.Proxy (Proxy(Proxy))
newtype MutateGovernorDatum = MutateGovernorDatum

4
agora-purescript-bridge/src/Agora/Effect/TreasuryWithdrawal.purs
View file

@ -10,8 +10,8 @@ import Data.Lens.Record (prop)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Tuple (Tuple)
import Plutus.V1.Ledger.Credential (Credential)
import Plutus.V1.Ledger.Value (Value)
import PlutusLedgerApi.V1.Credential (Credential)
import PlutusLedgerApi.V1.Value (Value)
import Type.Proxy (Proxy(Proxy))
newtype TreasuryWithdrawalDatum = TreasuryWithdrawalDatum

4
agora-purescript-bridge/src/Agora/Governor.purs
View file

@ -17,8 +17,8 @@ import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Tagged (Tagged)
import GHC.Num.Integer (Integer)
import Plutus.V1.Ledger.Tx (TxOutRef)
import Plutus.V1.Ledger.Value (AssetClass)
import PlutusLedgerApi.V1.Tx (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass)
import Type.Proxy (Proxy(Proxy))
newtype GovernorDatum = GovernorDatum

2
agora-purescript-bridge/src/Agora/MultiSig.purs
View file

@ -10,7 +10,7 @@ import Data.Lens.Record (prop)
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import GHC.Num.Integer (Integer)
import Plutus.V1.Ledger.Crypto (PubKeyHash)
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
import Type.Proxy (Proxy(Proxy))
newtype MultiSig = MultiSig

6
agora-purescript-bridge/src/Agora/Proposal.purs
View file

@ -16,9 +16,9 @@ import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Tagged (Tagged)
import GHC.Num.Integer (Integer)
import Plutus.V1.Ledger.Crypto (PubKeyHash)
import Plutus.V1.Ledger.Scripts (DatumHash, ValidatorHash)
import Plutus.V1.Ledger.Value (AssetClass)
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
import PlutusLedgerApi.V1.Scripts (DatumHash, ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass)
import PlutusTx.AssocMap (Map)
import Type.Proxy (Proxy(Proxy))

4
agora-purescript-bridge/src/Agora/Stake.purs
View file

@ -13,8 +13,8 @@ import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Tagged (Tagged)
import GHC.Num.Integer (Integer)
import Plutus.V1.Ledger.Crypto (PubKeyHash)
import Plutus.V1.Ledger.Value (AssetClass)
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
import PlutusLedgerApi.V1.Value (AssetClass)
import Type.Proxy (Proxy(Proxy))
newtype Stake = Stake

6
agora-scripts/Scripts.hs
View file

@ -31,9 +31,9 @@ import Data.Tagged (Tagged)
import GHC.Generics qualified as GHC
import Options (Options (..), parseOptions)
import Plutarch.Api.V1 (mintingPolicySymbol, mkMintingPolicy)
import Plutus.V1.Ledger.Api (TxOutRef)
import Plutus.V1.Ledger.Value (AssetClass, CurrencySymbol)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass, CurrencySymbol)
import PlutusLedgerApi.V1.Value qualified as Value
import System.Exit (exitFailure)
import Text.Printf (printf)

2
agora-scripts/agora-scripts.json
View file

File diff suppressed because one or more lines are too long

8
agora-specs/Property/Generator.hs
View file

@ -21,8 +21,8 @@ module Property.Generator (
import Control.Applicative (Applicative (liftA2))
import Data.ByteString.Char8 qualified as C (ByteString, pack)
import Data.ByteString.Hash (sha2)
import Plutus.V1.Ledger.Api (
import Data.ByteString.Hash (sha2_256)
import PlutusLedgerApi.V1 (
Address (Address),
Credential (..),
PubKeyHash (PubKeyHash),
@ -30,7 +30,7 @@ import Plutus.V1.Ledger.Api (
Value,
toBuiltin,
)
import Plutus.V1.Ledger.Value (
import PlutusLedgerApi.V1.Value (
AssetClass (AssetClass),
assetClassValue,
currencySymbol,
@ -50,7 +50,7 @@ Hashs cannot be shrunken; functions utilizing this function,
therefore, cannot be shrunken as well.
-}
genHashByteString :: Gen C.ByteString
genHashByteString = sha2 . C.pack . show <$> (chooseAny :: Gen Integer)
genHashByteString = sha2_256 . C.pack . show <$> (chooseAny :: Gen Integer)
-- TODO: How do I need to ensure uniqueness?

2
agora-specs/Property/MultiSig.hs
View file

@ -24,7 +24,7 @@ import Plutarch.Context.Spending (
signedWith,
spendingContext,
)
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
ScriptContext (scriptContextTxInfo),
TxInfo (txInfoSignatories),
)

10
agora-specs/Sample/Effect/GovernorMutation.hs
View file

@ -24,8 +24,7 @@ import Agora.Proposal (ProposalId (..), ProposalThresholds (..))
import Data.Tagged (Tagged (..))
import Plutarch.Api.V1 (mkValidator, validatorHash)
import Plutus.V1.Ledger.Address (scriptHashAddress)
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
Address,
Datum (..),
ToData (..),
@ -37,9 +36,10 @@ import Plutus.V1.Ledger.Api (
Validator,
ValidatorHash (..),
)
import Plutus.V1.Ledger.Api qualified as Interval
import Plutus.V1.Ledger.Value (AssetClass, assetClass)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1 qualified as Interval
import PlutusLedgerApi.V1.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Value (AssetClass, assetClass)
import PlutusLedgerApi.V1.Value qualified as Value
--------------------------------------------------------------------------------

12
agora-specs/Sample/Effect/TreasuryWithdrawal.hs
View file

@ -20,7 +20,7 @@ module Sample.Effect.TreasuryWithdrawal (
) where
import Plutarch.Api.V1 (mkValidator, validatorHash)
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
Address (Address),
Credential (..),
CurrencySymbol (CurrencySymbol),
@ -50,11 +50,11 @@ import Plutus.V1.Ledger.Api (
Value,
toBuiltin,
)
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Interval qualified as Interval
import PlutusLedgerApi.V1.Value qualified as Value
import Data.ByteString.Char8 qualified as C
import Data.ByteString.Hash (sha2)
import Data.ByteString.Hash (sha2_256)
import Agora.Effect.TreasuryWithdrawal (
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
@ -71,11 +71,11 @@ signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
-- | List of users who the effect will pay to.
users :: [Credential]
users = PubKeyCredential . PubKeyHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
users = PubKeyCredential . PubKeyHash . toBuiltin . sha2_256 . C.pack . show <$> ([1 ..] :: [Integer])
-- | List of users who the effect will pay to.
treasuries :: [Credential]
treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2 . C.pack . show <$> ([1 ..] :: [Integer])
treasuries = ScriptCredential . ValidatorHash . toBuiltin . sha2_256 . C.pack . show <$> ([1 ..] :: [Integer])
inputGAT :: TxInInfo
inputGAT =

17
agora-specs/Sample/Governor.hs
View file

@ -19,10 +19,11 @@ import Plutarch.Api.V1 (mkValidator, validatorHash)
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Address (scriptHashAddress)
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
Address (..),
BuiltinData (BuiltinData),
Credential (ScriptCredential),
Data (I),
Datum (..),
ScriptContext (..),
ScriptPurpose (Minting, Spending),
@ -35,12 +36,12 @@ import Plutus.V1.Ledger.Api (
Validator,
ValidatorHash (..),
)
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Scripts (unitDatum)
import Plutus.V1.Ledger.Value (
import PlutusLedgerApi.V1.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Interval qualified as Interval
import PlutusLedgerApi.V1.Value (
AssetClass (..),
)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
--------------------------------------------------------------------------------
@ -92,6 +93,10 @@ import Data.Default.Class (Default (def))
--------------------------------------------------------------------------------
-- | Unit datum
unitDatum :: Datum
unitDatum = Datum . BuiltinData $ I 0 -- This could be anything, really. It doesn't matter.
{- | A valid 'ScriptContext' for minting GST.
- Only the minting policy will be ran in the transaction.

8
agora-specs/Sample/Proposal.hs
View file

@ -29,7 +29,7 @@ import Plutarch.Api.V1 (
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
Address (Address),
Credential (ScriptCredential),
Datum (Datum),
@ -46,7 +46,7 @@ import Plutus.V1.Ledger.Api (
TxOutRef (TxOutRef),
ValidatorHash,
)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
--------------------------------------------------------------------------------
@ -431,9 +431,9 @@ voteOnProposal params =
-- | Parameters for state transition of proposals.
data TransitionParameters = TransitionParameters
{ -- The initial status of the propsoal.
initialProposalStatus :: ProposalStatus
initialProposalStatus :: ProposalStatus
, -- The starting time of the propsoal.
proposalStartingTime :: ProposalStartingTime
proposalStartingTime :: ProposalStartingTime
}
-- | Create a 'TxInfo' that update the status of a proposal.

12
agora-specs/Sample/Shared.hs
View file

@ -92,8 +92,7 @@ import Plutarch.Api.V1 (
mkValidator,
validatorHash,
)
import Plutus.V1.Ledger.Address (scriptHashAddress)
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
Address (Address),
Credential (ScriptCredential),
CurrencySymbol,
@ -107,12 +106,13 @@ import Plutus.V1.Ledger.Api (
UpperBound (..),
Value,
)
import Plutus.V1.Ledger.Contexts (
import PlutusLedgerApi.V1.Address (scriptHashAddress)
import PlutusLedgerApi.V1.Contexts (
TxOut (..),
)
import Plutus.V1.Ledger.Scripts (Validator, ValidatorHash (..))
import Plutus.V1.Ledger.Value (AssetClass, TokenName)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Scripts (Validator, ValidatorHash (..))
import PlutusLedgerApi.V1.Value (AssetClass, TokenName)
import PlutusLedgerApi.V1.Value qualified as Value
--------------------------------------------------------------------------------

10
agora-specs/Sample/Stake.hs
View file

@ -25,7 +25,7 @@ import Plutarch.Api.V1 (
mkValidator,
validatorHash,
)
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
Address (Address),
Credential (ScriptCredential),
Datum (Datum),
@ -38,10 +38,10 @@ import Plutus.V1.Ledger.Api (
TxOut (txOutAddress, txOutDatumHash, txOutValue),
ValidatorHash (ValidatorHash),
)
import Plutus.V1.Ledger.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Value (TokenName (TokenName))
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Contexts (TxOut (TxOut), TxOutRef (TxOutRef))
import PlutusLedgerApi.V1.Interval qualified as Interval
import PlutusLedgerApi.V1.Value (TokenName (TokenName))
import PlutusLedgerApi.V1.Value qualified as Value
--------------------------------------------------------------------------------

14
agora-specs/Sample/Treasury.hs
View file

@ -18,13 +18,13 @@ module Sample.Treasury (
) where
import Plutarch.Api.V1 (validatorHash)
import Plutus.V1.Ledger.Address (Address (..))
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
BuiltinByteString,
Credential (PubKeyCredential),
PubKeyHash (PubKeyHash),
)
import Plutus.V1.Ledger.Contexts (
import PlutusLedgerApi.V1.Address (Address (..))
import PlutusLedgerApi.V1.Contexts (
ScriptContext (..),
ScriptPurpose (Minting),
TxInInfo (..),
@ -32,12 +32,12 @@ import Plutus.V1.Ledger.Contexts (
TxOut (..),
TxOutRef (..),
)
import Plutus.V1.Ledger.Credential (Credential (ScriptCredential))
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Scripts (
import PlutusLedgerApi.V1.Credential (Credential (ScriptCredential))
import PlutusLedgerApi.V1.Interval qualified as Interval
import PlutusLedgerApi.V1.Scripts (
ValidatorHash (ValidatorHash),
)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Value qualified as Value
import Sample.Shared (
gatCs,
gatTn,

6
agora-specs/Spec/AuthorityToken.hs
View file

@ -17,7 +17,7 @@ import Prelude
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
Address (Address),
Credential (PubKeyCredential, ScriptCredential),
CurrencySymbol,
@ -29,8 +29,8 @@ import Plutus.V1.Ledger.Api (
ValidatorHash (ValidatorHash),
Value,
)
import Plutus.V1.Ledger.Interval qualified as Interval
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Interval qualified as Interval
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusTx.AssocMap qualified as AssocMap
import Test.Specification (
SpecificationTree,

2
agora-specs/Spec/Effect/GovernorMutation.hs
View file

@ -5,7 +5,7 @@ import Agora.Governor (GovernorDatum (..), GovernorRedeemer (MutateGovernor))
import Agora.Governor.Scripts (governorValidator)
import Agora.Proposal (ProposalId (..))
import Data.Default.Class (Default (def))
import Plutus.V1.Ledger.Api (ScriptContext (ScriptContext), ScriptPurpose (Spending))
import PlutusLedgerApi.V1 (ScriptContext (ScriptContext), ScriptPurpose (Spending))
import Sample.Effect.GovernorMutation (
effectRef,
govRef,

2
agora-specs/Spec/Effect/TreasuryWithdrawal.hs
View file

@ -11,7 +11,7 @@ import Agora.Effect.TreasuryWithdrawal (
TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
treasuryWithdrawalValidator,
)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Value qualified as Value
import Sample.Effect.TreasuryWithdrawal (
buildReceiversOutputFromDatum,
buildScriptContext,

10
agora-specs/Spec/Proposal.hs
View file

@ -41,7 +41,7 @@ import Agora.Stake (
import Agora.Stake.Scripts (stakeValidator)
import Data.Default.Class (Default (def))
import Data.Tagged (Tagged (Tagged), untag)
import Plutus.V1.Ledger.Api (ScriptContext (..), ScriptPurpose (..))
import PlutusLedgerApi.V1 (ScriptContext (..), ScriptPurpose (..))
import PlutusTx.AssocMap qualified as AssocMap
import Sample.Proposal qualified as Proposal
import Sample.Shared (signer, signer2)
@ -184,8 +184,8 @@ specs =
[
( ResultTag 0
, case initialState of
Draft -> 0
_ -> untag (def :: ProposalThresholds).countVoting + 1
Draft -> 0
_ -> untag (def :: ProposalThresholds).countVoting + 1
)
, (ResultTag 1, 0)
]
@ -231,8 +231,8 @@ specs =
[
( ResultTag 0
, case initialState of
Draft -> 0
_ -> untag (def :: ProposalThresholds).countVoting + 1
Draft -> 0
_ -> untag (def :: ProposalThresholds).countVoting + 1
)
, (ResultTag 1, 0)
]

8
agora-specs/Spec/Treasury.hs
View file

@ -25,18 +25,18 @@ import Agora.Treasury (
TreasuryRedeemer (SpendTreasuryGAT),
treasuryValidator,
)
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
DCert (DCertDelegRegKey),
)
import Plutus.V1.Ledger.Contexts (
import PlutusLedgerApi.V1.Contexts (
ScriptContext (scriptContextPurpose, scriptContextTxInfo),
ScriptPurpose (Certifying, Rewarding, Spending),
TxInfo (txInfoInputs, txInfoMint),
)
import Plutus.V1.Ledger.Credential (
import PlutusLedgerApi.V1.Credential (
StakingCredential (StakingHash),
)
import Plutus.V1.Ledger.Value qualified as Value
import PlutusLedgerApi.V1.Value qualified as Value
import Sample.Shared (
trCredential,
)

2
agora-testlib/Test/Specification.hs
View file

@ -51,7 +51,7 @@ import Plutarch.Api.V1 (PMintingPolicy, PValidator)
import Plutarch.Builtin (pforgetData)
import Plutarch.Evaluate (evalScript)
import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
import Plutus.V1.Ledger.Api (Script, ScriptContext)
import PlutusLedgerApi.V1 (Script, ScriptContext)
import PlutusTx.IsData qualified as PlutusTx (ToData)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertFailure, testCase)

8
agora-testlib/Test/Util.hs
View file

@ -25,8 +25,8 @@ import Data.ByteString.Lazy qualified as ByteString.Lazy
--------------------------------------------------------------------------------
import Plutarch.Crypto (pblake2b_256)
import Plutus.V1.Ledger.Interval as PlutusTx
import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash))
import PlutusLedgerApi.V1.Interval as PlutusTx
import PlutusLedgerApi.V1.Scripts (Datum (Datum), DatumHash (DatumHash))
import PlutusTx.AssocMap qualified as AssocMap
import PlutusTx.Builtins qualified as PlutusTx
import PlutusTx.IsData qualified as PlutusTx
@ -34,11 +34,11 @@ import PlutusTx.Ord qualified as PlutusTx
--------------------------------------------------------------------------------
{- | Create a pair from data for use in 'Plutus.V1.Ledger.Contexts.txInfoData'.
{- | Create a pair from data for use in 'PlutusLedgerApi.V1.Contexts.txInfoData'.
Example:
@
myTxInfo { 'Plutus.V1.Ledger.Contexts.txInfoData' = ['datumPair' myDatum] }
myTxInfo { 'PlutusLedgerApi.V1.Contexts.txInfoData' = ['datumPair' myDatum] }
@
-}
datumPair :: PlutusTx.ToData a => a -> (DatumHash, Datum)

4
agora.cabal
View file

@ -67,6 +67,7 @@ common lang
PatternGuards
PolyKinds
PostfixOperators
QualifiedDo
RankNTypes
RelaxedPolyRec
ScopedTypeVariables
@ -80,7 +81,6 @@ common lang
UndecidableInstances
ViewPatterns
OverloadedRecordDot
QualifiedDo
default-language: Haskell2010
@ -128,6 +128,7 @@ common test-deps
, tasty-hunit
, tasty-quickcheck
, universe
, universe-base
common exe-opts
ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0
@ -219,6 +220,7 @@ benchmark agora-bench
, agora-specs
, agora-testlib
, cassava
, mtl
, optparse-applicative
executable agora-scripts

8
agora/Agora/Aeson/Orphans.hs
View file

@ -18,9 +18,9 @@ import Data.Text.Encoding qualified as T
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api qualified as Plutus
import Plutus.V1.Ledger.Bytes qualified as Plutus
import Plutus.V1.Ledger.Value qualified as Plutus
import PlutusLedgerApi.V1 qualified as Plutus
import PlutusLedgerApi.V1.Bytes qualified as Plutus
import PlutusLedgerApi.V1.Value qualified as Plutus
--------------------------------------------------------------------------------
@ -60,7 +60,7 @@ instance (Coercible a Plutus.LedgerBytes) => Aeson.ToJSON (AsBase16Bytes a) wher
instance (Coercible Plutus.LedgerBytes a) => Aeson.FromJSON (AsBase16Bytes a) where
parseJSON v =
Aeson.parseJSON @T.Text v
>>= either (Aeson.parserThrowError []) (pure . coerce @_ @(AsBase16Bytes a))
>>= either (Aeson.parserThrowError [] . show) (pure . coerce @_ @(AsBase16Bytes a))
. Plutus.fromHex
. T.encodeUtf8

8
agora/Agora/AuthorityToken.hs
View file

@ -14,6 +14,8 @@ module Agora.AuthorityToken (
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
AmountGuarantees,
KeyGuarantees,
PAddress (..),
PCredential (..),
PCurrencySymbol (..),
@ -28,7 +30,7 @@ import Plutarch.Api.V1.AssetClass (passetClass, passetClassValueOf)
import Plutarch.Api.V1.AssocMap (PMap (PMap))
import "plutarch" Plutarch.Api.V1.Value (PValue (PValue))
import Plutarch.Builtin (pforgetData)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
--------------------------------------------------------------------------------
@ -100,10 +102,10 @@ authorityTokensValidIn = phoistAcyclic $
-- | Assert that a single authority token has been burned.
singleAuthorityTokenBurned ::
forall (s :: S).
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s PCurrencySymbol ->
Term s (PAsData PTxInfo) ->
Term s PValue ->
Term s (PValue keys amounts) ->
Term s PBool
singleAuthorityTokenBurned gatCs txInfo mint = unTermCont $ do
let gatAmountMinted :: Term _ PInteger

4
agora/Agora/Effect.hs
View file

@ -11,7 +11,7 @@ import Agora.AuthorityToken (singleAuthorityTokenBurned)
import Agora.Utils (tcassert, tclet, tcmatch, tctryFrom)
import Plutarch.Api.V1 (PCurrencySymbol, PScriptPurpose (PSpending), PTxInfo, PTxOutRef, PValidator, PValue)
import Plutarch.TryFrom ()
import Plutus.V1.Ledger.Value (CurrencySymbol)
import PlutusLedgerApi.V1.Value (CurrencySymbol)
--------------------------------------------------------------------------------
@ -43,7 +43,7 @@ makeEffect gatCs' f =
-- fetch minted values to ensure single GAT is burned
txInfo <- tcont $ pletFields @'["mint"] txInfo'
let mint :: Term _ PValue
let mint :: Term _ (PValue _ _)
mint = txInfo.mint
-- fetch script context

6
agora/Agora/Effect/GovernorMutation.hs
View file

@ -43,8 +43,8 @@ import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (TxOutRef)
import Plutus.V1.Ledger.Value (AssetClass (..))
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusTx qualified
--------------------------------------------------------------------------------
@ -208,7 +208,7 @@ mutateGovernorValidator gov = makeEffect (authorityTokenSymbolFromGovernor gov)
return $ popaque $ pconstant ()
where
-- Get the amount of GST in the a given value.
gstValueOf :: Term s (PValue :--> PInteger)
gstValueOf :: Term s (PValue _ _ :--> PInteger)
gstValueOf = phoistAcyclic $ plam $ \v -> pvalueOf # v # pconstant cs # pconstant tn
where
AssetClass (cs, tn) = governorSTAssetClassFromGovernor gov

2
agora/Agora/Effect/NoOp.hs
View file

@ -12,7 +12,7 @@ import Control.Applicative (Const)
import Agora.Effect (makeEffect)
import Plutarch.Api.V1 (PValidator)
import Plutarch.TryFrom (PTryFrom (..))
import Plutus.V1.Ledger.Value (CurrencySymbol)
import PlutusLedgerApi.V1.Value (CurrencySymbol)
-- | Dummy datum for NoOp effect.
newtype PNoOp (s :: S) = PNoOp (Term s PUnit)

13
agora/Agora/Effect/TreasuryWithdrawal.hs
View file

@ -20,12 +20,15 @@ import Generics.SOP (Generic, I (I))
import Agora.Effect (makeEffect)
import Agora.Utils (findTxOutByTxOutRef, isPubKey, paddValue, tcassert, tclet, tcmatch)
import Plutarch.Api.V1 (
AmountGuarantees (Positive),
KeyGuarantees (Sorted),
PCredential (..),
PTuple,
PValidator,
PValue,
ptuple,
)
import "plutarch" Plutarch.Api.V1.Value (pnormalize)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.DataRepr (
@ -35,8 +38,8 @@ import Plutarch.DataRepr (
)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutarch.TryFrom (PTryFrom (..))
import Plutus.V1.Ledger.Credential (Credential)
import Plutus.V1.Ledger.Value (CurrencySymbol, Value)
import PlutusLedgerApi.V1.Credential (Credential)
import PlutusLedgerApi.V1.Value (CurrencySymbol, Value)
import PlutusTx qualified
{- | Datum that encodes behavior of Treasury Withdrawal effect.
@ -63,7 +66,7 @@ newtype PTreasuryWithdrawalDatum (s :: S)
( Term
s
( PDataRecord
'[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential PValue))
'[ "receivers" ':= PBuiltinList (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
, "treasuries" ':= PBuiltinList (PAsData PCredential)
]
)
@ -135,8 +138,8 @@ treasuryWithdrawalValidator currSymbol = makeEffect currSymbol $
# plam (\((pfield @"_0" #) . pfromData -> cred) -> pelem # cred # datum.treasuries)
sumValues =
pfoldr
# plam (\((pfield @"_1" #) . pfromData -> x) y -> paddValue # pfromData x # y)
# pconstant (mempty :: Value)
# plam (\((pfield @"_1" #) . pfromData -> x) ((pnormalize #) -> y) -> paddValue # pfromData x # y)
# punsafeCoerce (pconstant (mempty :: Value))
treasuryInputValuesSum = sumValues #$ ofTreasury # inputValues
treasuryOutputValuesSum = sumValues #$ ofTreasury # outputValues
receiverValuesSum = sumValues # datum.receivers

22
agora/Agora/Governor.hs
View file

@ -63,8 +63,8 @@ import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (TxOutRef)
import Plutus.V1.Ledger.Value (AssetClass (..))
import PlutusLedgerApi.V1 (TxOutRef)
import PlutusLedgerApi.V1.Value (AssetClass (..))
import PlutusTx qualified
--------------------------------------------------------------------------------
@ -127,15 +127,15 @@ data Governor = Governor
-- | Plutarch-level datum for the Governor script.
newtype PGovernorDatum (s :: S) = PGovernorDatum
{ getGovernorDatum ::
Term
s
( PDataRecord
'[ "proposalThresholds" ':= PProposalThresholds
, "nextProposalId" ':= PProposalId
, "proposalTimings" ':= PProposalTimingConfig
, "createProposalTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
]
)
Term
s
( PDataRecord
'[ "proposalThresholds" ':= PProposalThresholds
, "nextProposalId" ':= PProposalId
, "proposalTimings" ':= PProposalTimingConfig
, "createProposalTimeRangeMaxWidth" ':= PMaxTimeRangeWidth
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)

10
agora/Agora/Governor/Scripts.hs
View file

@ -125,12 +125,12 @@ import Plutarch.TryFrom ()
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
CurrencySymbol (..),
MintingPolicy,
)
import Plutus.V1.Ledger.Scripts (ValidatorHash (..))
import Plutus.V1.Ledger.Value (
import PlutusLedgerApi.V1.Scripts (ValidatorHash (..))
import PlutusLedgerApi.V1.Value (
AssetClass (..),
)
@ -631,7 +631,7 @@ governorValidator gov =
tcassert "Output GATs is more than minted GATs" $
plength # outputsWithGAT #== gatCount
let gatOutputValidator' :: Term s (PMap PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool)
let gatOutputValidator' :: Term s (PMap _ PValidatorHash PDatumHash :--> PAsData PTxOut :--> PBool)
gatOutputValidator' =
phoistAcyclic $
plam
@ -679,7 +679,7 @@ governorValidator gov =
pure $ popaque $ singleAuthorityTokenBurned patSymbol ctxF.txInfo txInfoF.mint
where
-- Get th amount of governance tokens in a value.
pgtValueOf :: Term s (PValue :--> PDiscrete GTTag)
pgtValueOf :: Term s (PValue _ _ :--> PDiscrete GTTag)
pgtValueOf = phoistAcyclic $ pvalueDiscrete' gov.gtClassRef
-- The currency symbol of authority token.

16
agora/Agora/MultiSig.hs
View file

@ -29,7 +29,7 @@ import Plutarch.Lift (
PUnsafeLiftDecl,
)
import Plutus.V1.Ledger.Crypto (PubKeyHash)
import PlutusLedgerApi.V1.Crypto (PubKeyHash)
import PlutusTx qualified
--------------------------------------------------------------------------------
@ -57,13 +57,13 @@ PlutusTx.unstableMakeIsData ''MultiSig
-- | Plutarch-level MultiSig
newtype PMultiSig (s :: S) = PMultiSig
{ getMultiSig ::
Term
s
( PDataRecord
'[ "keys" ':= PBuiltinList (PAsData PPubKeyHash)
, "minSigs" ':= PInteger
]
)
Term
s
( PDataRecord
'[ "keys" ':= PBuiltinList (PAsData PPubKeyHash)
, "minSigs" ':= PInteger
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)

59
agora/Agora/Proposal.hs
View file

@ -38,6 +38,7 @@ module Agora.Proposal (
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (
KeyGuarantees (Unsorted),
PDatumHash,
PMap,
PPubKeyHash,
@ -63,8 +64,8 @@ import Plutarch.Lift (
import Plutarch.SafeMoney (PDiscrete)
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.Unsafe (punsafeCoerce)
import Plutus.V1.Ledger.Api (DatumHash, PubKeyHash, ValidatorHash)
import Plutus.V1.Ledger.Value (AssetClass)
import PlutusLedgerApi.V1 (DatumHash, PubKeyHash, ValidatorHash)
import PlutusLedgerApi.V1.Value (AssetClass)
--------------------------------------------------------------------------------
-- Haskell-land
@ -322,14 +323,14 @@ deriving via (DerivePConstantViaData ProposalStatus PProposalStatus) instance (P
-- | Plutarch-level version of 'ProposalThresholds'.
newtype PProposalThresholds (s :: S) = PProposalThresholds
{ getProposalThresholds ::
Term
s
( PDataRecord
'[ "execute" ':= PDiscrete GTTag
, "draft" ':= PDiscrete GTTag
, "vote" ':= PDiscrete GTTag
]
)
Term
s
( PDataRecord
'[ "execute" ':= PDiscrete GTTag
, "draft" ':= PDiscrete GTTag
, "vote" ':= PDiscrete GTTag
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
@ -343,17 +344,17 @@ deriving via (DerivePConstantViaData ProposalThresholds PProposalThresholds) ins
-- | Plutarch-level version of 'ProposalVotes'.
newtype PProposalVotes (s :: S)
= PProposalVotes (Term s (PMap PResultTag PInteger))
deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap PResultTag PInteger))
= PProposalVotes (Term s (PMap 'Unsorted PResultTag PInteger))
deriving (PlutusType, PIsData) via (DerivePNewtype PProposalVotes (PMap 'Unsorted PResultTag PInteger))
instance PUnsafeLiftDecl PProposalVotes where type PLifted PProposalVotes = ProposalVotes
deriving via
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap PResultTag PInteger))
(DerivePConstantViaNewtype ProposalVotes PProposalVotes (PMap 'Unsorted PResultTag PInteger))
instance
(PConstantDecl ProposalVotes)
-- | Plutarch-level version of 'emptyVotesFor'.
pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap PResultTag a :--> PProposalVotes)
pemptyVotesFor :: forall s a. (PIsData a) => Term s (PMap 'Unsorted PResultTag a :--> PProposalVotes)
pemptyVotesFor =
phoistAcyclic $
plam
@ -365,19 +366,19 @@ pemptyVotesFor =
-- | Plutarch-level version of 'ProposalDatum'.
newtype PProposalDatum (s :: S) = PProposalDatum
{ getProposalDatum ::
Term
s
( PDataRecord
'[ "proposalId" ':= PProposalId
, "effects" ':= PMap PResultTag (PMap PValidatorHash PDatumHash)
, "status" ':= PProposalStatus
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
, "thresholds" ':= PProposalThresholds
, "votes" ':= PProposalVotes
, "timingConfig" ':= PProposalTimingConfig
, "startingTime" ':= PProposalStartingTime
]
)
Term
s
( PDataRecord
'[ "proposalId" ':= PProposalId
, "effects" ':= PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
, "status" ':= PProposalStatus
, "cosigners" ':= PBuiltinList (PAsData PPubKeyHash)
, "thresholds" ':= PProposalThresholds
, "votes" ':= PProposalVotes
, "timingConfig" ':= PProposalTimingConfig
, "startingTime" ':= PProposalStartingTime
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
@ -530,7 +531,7 @@ phighestVotes = phoistAcyclic $
pneutralOption ::
Term
s
( PMap PResultTag (PMap PValidatorHash PDatumHash)
( PMap 'Unsorted PResultTag (PMap 'Unsorted PValidatorHash PDatumHash)
:--> PResultTag
)
pneutralOption = phoistAcyclic $
@ -538,7 +539,7 @@ pneutralOption = phoistAcyclic $
let l :: Term _ (PBuiltinList (PBuiltinPair (PAsData PResultTag) _))
l = pto effects
f :: Term _ (PBuiltinPair (PAsData PResultTag) (PAsData (PMap _ _)) :--> PBool)
f :: Term _ (PBuiltinPair (PAsData PResultTag) (PAsData (PMap 'Unsorted _ _)) :--> PBool)
f = phoistAcyclic $
plam $ \((pfromData . (psndBuiltin #) -> el)) ->
let el' :: Term _ (PBuiltinList _)

2
agora/Agora/Proposal/Scripts.hs
View file

@ -56,7 +56,7 @@ import Plutarch.Extra.Map (plookup)
import Plutarch.Extra.Record (mkRecordConstr, (.&), (.=))
import Plutarch.Extra.TermCont (pmatchC)
import Plutarch.SafeMoney (PDiscrete (..))
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
{- | Policy for Proposals.

30
agora/Agora/Proposal/Time.hs
View file

@ -52,7 +52,7 @@ import Plutarch.Lift (
)
import Plutarch.Numeric.Additive (AdditiveSemigroup ((+)))
import Plutarch.Unsafe (punsafeCoerce)
import Plutus.V1.Ledger.Time (POSIXTime)
import PlutusLedgerApi.V1.Time (POSIXTime)
import PlutusTx qualified
import Prelude hiding ((+))
@ -83,7 +83,7 @@ data ProposalTimingConfig = ProposalTimingConfig
PlutusTx.makeIsDataIndexed ''ProposalTimingConfig [('ProposalTimingConfig, 0)]
-- | Represents the maximum width of a 'Plutus.V1.Ledger.Time.POSIXTimeRange'.
-- | Represents the maximum width of a 'PlutusLedgerApi.V1.Time.POSIXTimeRange'.
newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
deriving stock (Eq, Show, Ord, GHC.Generic)
deriving newtype (PlutusTx.ToData, PlutusTx.FromData, PlutusTx.UnsafeFromData)
@ -106,8 +106,8 @@ newtype MaxTimeRangeWidth = MaxTimeRangeWidth {getMaxWidth :: POSIXTime}
Various functions work simply on 'PProposalTime' and 'ProposalTimingConfig'.
In particular, 'currentProposalTime' is useful for extracting the time
from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field
of 'Plutus.V1.Ledger.Api.TxInfo'.
from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field
of 'PlutusLedgerApi.V1.TxInfo'.
We avoid 'PPOSIXTimeRange' where we can in order to save on operations.
@ -136,15 +136,15 @@ deriving via
-- | Plutarch-level version of 'ProposalTimingConfig'.
newtype PProposalTimingConfig (s :: S) = PProposalTimingConfig
{ getProposalTimingConfig ::
Term
s
( PDataRecord
'[ "draftTime" ':= PPOSIXTime
, "votingTime" ':= PPOSIXTime
, "lockingTime" ':= PPOSIXTime
, "executingTime" ':= PPOSIXTime
]
)
Term
s
( PDataRecord
'[ "draftTime" ':= PPOSIXTime
, "votingTime" ':= PPOSIXTime
, "lockingTime" ':= PPOSIXTime
, "executingTime" ':= PPOSIXTime
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
@ -177,7 +177,7 @@ deriving via
instance AdditiveSemigroup (Term s PPOSIXTime) where
(punsafeCoerce @_ @_ @PInteger -> x) + (punsafeCoerce @_ @_ @PInteger -> y) = punsafeCoerce $ x + y
{- | Get the starting time of a proposal, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
{- | Get the starting time of a proposal, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
For every proposal, this is only meant to run once upon creation. Given time range should be
tight enough, meaning that the width of the time range should be less than the maximum value.
-}
@ -199,7 +199,7 @@ createProposalStartingTime = phoistAcyclic $
pure $ pcon $ PProposalStartingTime startingTime
{- | Get the current proposal time, from the 'Plutus.V1.Ledger.Api.txInfoValidPeriod' field.
{- | Get the current proposal time, from the 'PlutusLedgerApi.V1.txInfoValidPeriod' field.
If it's impossible to get a fully-bounded time, (e.g. either end of the 'PPOSIXTimeRange' is
an infinity) then we error out.

2
agora/Agora/SafeMoney.hs
View file

@ -16,7 +16,7 @@ module Agora.SafeMoney (
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Data.Tagged (Tagged (Tagged))

4
agora/Agora/ScriptInfo.hs
View file

@ -19,8 +19,8 @@ import Agora.Aeson.Orphans ()
import Data.Aeson qualified as Aeson
import GHC.Generics qualified as GHC
import Plutarch.Api.V1 (PMintingPolicy, PValidator, mintingPolicySymbol, mkMintingPolicy, mkValidator, validatorHash)
import Plutus.V1.Ledger.Api (MintingPolicy, Validator, ValidatorHash)
import Plutus.V1.Ledger.Value (CurrencySymbol)
import PlutusLedgerApi.V1 (MintingPolicy, Validator, ValidatorHash)
import PlutusLedgerApi.V1.Value (CurrencySymbol)
-- | Bundle containing a 'Validator' and its hash.
data ValidatorInfo = ValidatorInfo

34
agora/Agora/Stake.hs
View file

@ -32,7 +32,7 @@ import Prelude hiding (Num (..))
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (PubKeyHash)
import PlutusLedgerApi.V1 (PubKeyHash)
import PlutusTx qualified
--------------------------------------------------------------------------------
@ -53,7 +53,7 @@ import Plutarch.DataRepr (
)
import Plutarch.Internal (punsafeCoerce)
import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (..))
import Plutus.V1.Ledger.Value (AssetClass)
import PlutusLedgerApi.V1.Value (AssetClass)
--------------------------------------------------------------------------------
@ -175,14 +175,14 @@ PlutusTx.makeIsDataIndexed ''StakeDatum [('StakeDatum, 0)]
-- | Plutarch-level datum for Stake scripts.
newtype PStakeDatum (s :: S) = PStakeDatum
{ getStakeDatum ::
Term
s
( PDataRecord
'[ "stakedAmount" ':= PDiscrete GTTag
, "owner" ':= PPubKeyHash
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
]
)
Term
s
( PDataRecord
'[ "stakedAmount" ':= PDiscrete GTTag
, "owner" ':= PPubKeyHash
, "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)
@ -226,13 +226,13 @@ deriving via (DerivePConstantViaData StakeRedeemer PStakeRedeemer) instance (PCo
-- | Plutarch-level version of 'ProposalLock'.
newtype PProposalLock (s :: S) = PProposalLock
{ getProposalLock ::
Term
s
( PDataRecord
'[ "vote" ':= PResultTag
, "proposalTag" ':= PProposalId
]
)
Term
s
( PDataRecord
'[ "vote" ':= PResultTag
, "proposalTag" ':= PProposalId
]
)
}
deriving stock (GHC.Generic)
deriving anyclass (Generic)

16
agora/Agora/Stake/Scripts.hs
View file

@ -28,12 +28,14 @@ import Agora.Utils (
)
import Data.Tagged (Tagged (..), untag)
import Plutarch.Api.V1 (
AmountGuarantees (Positive),
PCredential (PPubKeyCredential, PScriptCredential),
PMintingPolicy,
PScriptPurpose (PMinting, PSpending),
PTokenName,
PTxInfo,
PValidator,
PValue,
mintingPolicySymbol,
mkMintingPolicy,
)
@ -45,7 +47,7 @@ import Plutarch.SafeMoney (
pdiscreteValue',
pvalueDiscrete',
)
import Plutus.V1.Ledger.Value (AssetClass (AssetClass))
import PlutusLedgerApi.V1.Value (AssetClass (AssetClass))
import Prelude hiding (Num (..))
{- | Policy for Stake state threads.
@ -57,7 +59,7 @@ import Prelude hiding (Num (..))
- 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 @'Plutus.V1.Ledger.Api.TokenName' == 'Plutus.V1.Ledger.Api.ValidatorHash'@
- assert @'PlutusLedgerApi.V1.TokenName' == 'PlutusLedgerApi.V1.ValidatorHash'@
of the script that we pay to.
=== For burning:
@ -226,7 +228,8 @@ stakeValidator stake =
PJust txInInfo <- tcmatch $ pfindTxInByTxOutRef # (pfield @"_0" # txOutRef) # txInfoF.inputs
ownAddress <- tclet $ pfield @"address" #$ pfield @"resolved" # txInInfo
let continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
let continuingValue :: Term _ (PValue _ _)
continuingValue = pfield @"value" #$ pfield @"resolved" # txInInfo
-- Whether the owner signs this transaction or not.
ownerSignsTransaction <- tclet $ ptxSignedBy # txInfoF.signatories # stakeDatum.owner
@ -413,8 +416,11 @@ stakeValidator stake =
)
datumCorrect = stakeOut #== expectedDatum
let expectedValue =
paddValue # continuingValue # (pdiscreteValue' stake.gtClassRef # delta)
let valueDelta :: Term _ (PValue _ 'Positive)
valueDelta = pdiscreteValue' stake.gtClassRef # delta
expectedValue =
paddValue # continuingValue # valueDelta
valueCorrect =
foldr1

4
agora/Agora/Treasury.hs
View file

@ -23,7 +23,7 @@ import Plutarch.DataRepr (
)
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
import Plutarch.TryFrom ()
import Plutus.V1.Ledger.Value (CurrencySymbol)
import PlutusLedgerApi.V1.Value (CurrencySymbol)
import PlutusTx qualified
--------------------------------------------------------------------------------
@ -90,7 +90,7 @@ treasuryValidator gatCs' = plam $ \_datum redeemer ctx' -> unTermCont $ do
-- Get the minted value from txInfo.
txInfo' <- tclet ctx.txInfo
txInfo <- tcont $ pletFields @'["mint"] txInfo'
let mint :: Term _ PValue
let mint :: Term _ (PValue _ _)
mint = txInfo.mint
gatCs <- tclet $ pconstant gatCs'

75
agora/Agora/Utils.hs
View file

@ -65,18 +65,20 @@ module Agora.Utils (
--------------------------------------------------------------------------------
import Plutus.V1.Ledger.Api (
import PlutusLedgerApi.V1 (
Address (..),
Credential (..),
CurrencySymbol,
TokenName (..),
ValidatorHash (..),
)
import Plutus.V1.Ledger.Value (AssetClass (..))
import PlutusLedgerApi.V1.Value (AssetClass (..))
--------------------------------------------------------------------------------
import Plutarch.Api.V1 (
AmountGuarantees (NoGuarantees, NonZero, Positive),
KeyGuarantees (Sorted, Unsorted),
PAddress,
PCredential (PScriptCredential),
PCurrencySymbol,
@ -103,6 +105,7 @@ import Plutarch.Builtin (pforgetData, ppairDataBuiltin)
import Plutarch.Extra.Map (pkeys)
import Plutarch.Reducible (Reducible (Reduce))
import Plutarch.TryFrom (PTryFrom (PTryFromExcess))
import Plutarch.Unsafe (punsafeCoerce)
--------------------------------------------------------------------------------
-- TermCont-based combinators. Some of these will live in plutarch eventually.
@ -222,7 +225,9 @@ pisJust = phoistAcyclic $
PNothing -> pconstant False
-- | Get the sum of all values belonging to a particular CurrencySymbol.
psymbolValueOf :: Term s (PCurrencySymbol :--> PValue :--> PInteger)
psymbolValueOf ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s (PCurrencySymbol :--> PValue keys amounts :--> PInteger)
psymbolValueOf =
phoistAcyclic $
plam $ \sym value'' -> unTermCont $ do
@ -233,33 +238,46 @@ psymbolValueOf =
pure $ pfoldr # plam (\x v -> pfromData (psndBuiltin # x) + v) # 0 # m
-- | Extract amount from PValue belonging to a Haskell-level AssetClass.
passetClassValueOf' :: AssetClass -> Term s (PValue :--> PInteger)
passetClassValueOf' ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
AssetClass ->
Term s (PValue keys amounts :--> PInteger)
passetClassValueOf' (AssetClass (sym, token)) =
phoistAcyclic $ plam $ \value -> pvalueOf # value # pconstant sym # pconstant token
-- | Return '>=' on two values comparing by only a particular AssetClass.
pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool)
pgeqByClass ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s (PCurrencySymbol :--> PTokenName :--> PValue keys amounts :--> PValue keys amounts :--> PBool)
pgeqByClass =
phoistAcyclic $
plam $ \cs tn a b ->
pvalueOf # b # cs # tn #<= pvalueOf # a # cs # tn
-- | Return '>=' on two values comparing by only a particular CurrencySymbol.
pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool)
pgeqBySymbol ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s (PCurrencySymbol :--> PValue keys amounts :--> PValue keys amounts :--> 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.
pgeqByClass' :: AssetClass -> Term s (PValue :--> PValue :--> PBool)
pgeqByClass' ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
AssetClass ->
Term s (PValue keys amounts :--> PValue keys amounts :--> PBool)
pgeqByClass' ac =
phoistAcyclic $
plam $ \a b ->
passetClassValueOf' ac # b #<= passetClassValueOf' ac # a
-- | 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 ::
forall (k :: PType) (v :: PType) (keys :: KeyGuarantees) (s :: S).
PIsData v =>
Term s ((v :--> v :--> v) :--> PMap keys k v :--> PMap keys k v :--> PMap keys k v)
pmapUnionWith = phoistAcyclic $
-- TODO: this function is kinda suspect. I feel like a lot of optimizations could be done here
plam $ \f xs' ys' -> unTermCont $ do
@ -301,7 +319,10 @@ pmapMaybe = phoistAcyclic $
_ -> self # f # xs
-- | / O(n) /. Update the value at a given key in a `PMap`, have the same functionalities as 'Data.Map.update'.
pupdate :: forall s k v. (PIsData k, PIsData v) => Term s ((v :--> PMaybe v) :--> k :--> PMap k v :--> PMap k v)
pupdate ::
forall (k :: PType) (v :: PType) (keys :: KeyGuarantees) (s :: S).
(PIsData k, PIsData v) =>
Term s ((v :--> PMaybe v) :--> k :--> PMap keys k v :--> PMap keys k v)
pupdate = phoistAcyclic $
plam $ \f (pdata -> tk) (pto -> (ps :: Term _ (PBuiltinList _))) ->
pcon $
@ -324,7 +345,10 @@ pupdate = phoistAcyclic $
# ps
-- | / O(n) /. Map a function over all values in a 'PMap'.
pmapMap :: forall s k a b. (PIsData k, PIsData a, PIsData b) => Term s ((a :--> b) :--> PMap k a :--> PMap k b)
pmapMap ::
forall (k :: PType) (a :: PType) (b :: PType) (keys :: KeyGuarantees) (s :: S).
(PIsData k, PIsData a, PIsData b) =>
Term s ((a :--> b) :--> PMap keys k a :--> PMap keys k b)
pmapMap = phoistAcyclic $
plam $ \f (pto -> (ps :: Term _ (PBuiltinList _))) ->
pcon $
@ -340,8 +364,15 @@ pmapMap = phoistAcyclic $
)
# ps
-- | Compute the guarantees known after adding two values.
type family AddGuarantees (a :: AmountGuarantees) (b :: AmountGuarantees) where
AddGuarantees 'Positive 'Positive = 'Positive
AddGuarantees _ _ = 'NoGuarantees
-- | Add two 'PValue's together.
paddValue :: forall s. Term s (PValue :--> PValue :--> PValue)
paddValue ::
forall (keys :: KeyGuarantees) (as :: AmountGuarantees) (bs :: AmountGuarantees) (s :: S).
Term s (PValue keys as :--> PValue keys bs :--> PValue keys (AddGuarantees as bs))
paddValue = phoistAcyclic $
plam $ \a' b' -> unTermCont $ do
PValue a <- tcmatch a'
@ -353,7 +384,9 @@ paddValue = phoistAcyclic $
)
-- | Sum of all value at input.
pvalueSpent :: Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue)
pvalueSpent ::
forall (s :: S).
Term s (PBuiltinList (PAsData PTxInInfo) :--> PValue 'Sorted 'Positive)
pvalueSpent = phoistAcyclic $
plam $ \inputs ->
pfoldr
@ -368,7 +401,8 @@ pvalueSpent = phoistAcyclic $
(\(PTxOut o) -> pfromData $ pfield @"value" # o)
# v
)
# pconstant mempty
-- TODO: This should be possible without coercions, but I can't figure out the types atm.
# punsafeCoerce (pconstant mempty :: Term _ (PValue 'Unsorted 'NonZero))
# inputs
-- | Find the TxInInfo by a TxOutRef.
@ -415,7 +449,10 @@ ptokenSpent =
{- | True if both maps have exactly the same keys.
Using @'#=='@ is not sufficient, because keys returned are not ordered.
-}
pkeysEqual :: (POrd k, PIsData k) => forall (s :: S) a b. Term s (PMap k a :--> PMap k b :--> PBool)
pkeysEqual ::
forall (k :: PType) (a :: PType) (b :: PType) (keys :: KeyGuarantees) (s :: S).
(POrd k, PIsData k) =>
Term s (PMap keys k a :--> PMap keys k b :--> PBool)
pkeysEqual = phoistAcyclic $
plam $ \p q -> unTermCont $ do
pks <- tclet $ pkeys # p
@ -575,7 +612,9 @@ phalve = phoistAcyclic $ plam $ \l -> go # l # l
-}
-- | Create a value with a single asset class.
psingletonValue :: forall s. Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue)
psingletonValue ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s (PCurrencySymbol :--> PTokenName :--> PInteger :--> PValue keys amounts)
psingletonValue = phoistAcyclic $
plam $ \sym tok int ->
let innerTup = pcon $ PMap $ psingleton #$ ppairDataBuiltin # pdata tok # pdata int
@ -645,7 +684,9 @@ getMintingPolicySymbol :: ClosedTerm PMintingPolicy -> CurrencySymbol
getMintingPolicySymbol v = mintingPolicySymbol $ mkMintingPolicy v
-- | The entire value only contains one token of the given currency symbol.
hasOnlyOneTokenOfCurrencySymbol :: Term s (PCurrencySymbol :--> PValue :--> PBool)
hasOnlyOneTokenOfCurrencySymbol ::
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
Term s (PCurrencySymbol :--> PValue keys amounts :--> PBool)
hasOnlyOneTokenOfCurrencySymbol = phoistAcyclic $
plam $ \cs vs -> P.do
psymbolValueOf # cs # vs #== 1
@ -687,6 +728,6 @@ mustBePDJust = phoistAcyclic $
PDJust ((pfield @"_0" #) -> v) -> v
_ -> ptraceError emsg
-- | Create an 'Address' from a given 'ValidatorHash' with no 'Plutus.V1.Ledger.Credential.StakingCredential'.
-- | Create an 'Address' from a given 'ValidatorHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.
validatorHashToAddress :: ValidatorHash -> Address
validatorHashToAddress vh = Address (ScriptCredential vh) Nothing

56
bench.csv
View file

@ -1,29 +1,29 @@
name,cpu,mem,size
Agora/Effects/Treasury Withdrawal Effect/effect/Simple,340268715,724428,3050
Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries ,570029812,1211300,3377
Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,502351827,1071087,3242
Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,103830462,228928,7629
Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,127968605,266935,3358
Agora/Stake/policy/stakeCreation,59776675,126049,2116
Agora/Stake/validator/stakeDepositWithdraw deposit,276249331,599197,4024
Agora/Stake/validator/stakeDepositWithdraw withdraw,276249331,599197,4016
Agora/Proposal/policy/proposalCreation,34784356,68894,1523
Agora/Proposal/validator/cosignature/proposal,241651391,511819,5644
Agora/Proposal/validator/cosignature/stake,186332635,402961,4561
Agora/Proposal/validator/voting/proposal,240181636,491168,5652
Agora/Proposal/validator/voting/stake,154223940,328703,4614
Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,131365724,260351,5030
Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,130643392,258848,5039
Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,132128827,262454,5039
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,129853757,257621,5032
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,128636280,254916,5039
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,129626570,257320,5039
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,25177457,55883,806
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,40266637,88241,900
Agora/Treasury/Validator/Positive/Allows for effect changes,37343572,79744,1841
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,25177457,55883,806
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,40266637,88241,900
Agora/Governor/policy/GST minting,57978053,120125,1833
Agora/Governor/validator/proposal creation,330344593,681815,8145
Agora/Governor/validator/GATs minting,442720585,955552,8268
Agora/Governor/validator/mutate governor state,101019422,223202,7686
Agora/Effects/Treasury Withdrawal Effect/effect/Simple,317467035,778238,3172
Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries ,555940189,1350738,3499
Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets,488765974,1174701,3364
Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass,83689582,228928,7629
Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass,97345575,266935,3358
Agora/Stake/policy/stakeCreation,43459609,126049,2116
Agora/Stake/validator/stakeDepositWithdraw deposit,226083166,599197,4024
Agora/Stake/validator/stakeDepositWithdraw withdraw,226083166,599197,4016
Agora/Proposal/policy/proposalCreation,23071177,68894,1523
Agora/Proposal/validator/cosignature/proposal,190181087,511819,5644
Agora/Proposal/validator/cosignature/stake,162540553,402961,4561
Agora/Proposal/validator/voting/proposal,181998338,491168,5652
Agora/Proposal/validator/voting/stake,127693475,328703,4614
Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady,98071575,260351,5030
Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked,97228153,258848,5039
Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished,98924620,262454,5039
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished,96941774,257621,5032
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished,95532863,254916,5039
Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished,96663841,257320,5039
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900
Agora/Treasury/Validator/Positive/Allows for effect changes,29938856,79744,1841
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple,21017788,55883,806
Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs,33204186,88241,900
Agora/Governor/policy/GST minting,43087287,120125,1833
Agora/Governor/validator/proposal creation,258936253,681815,8145
Agora/Governor/validator/GATs minting,358292569,955552,8266
Agora/Governor/validator/mutate governor state,81661538,223202,7682

1 name cpu mem size
2 Agora/Effects/Treasury Withdrawal Effect/effect/Simple 340268715 317467035 724428 778238 3050 3172
3 Agora/Effects/Treasury Withdrawal Effect/effect/Simple with multiple treasuries 570029812 555940189 1211300 1350738 3377 3499
4 Agora/Effects/Treasury Withdrawal Effect/effect/Mixed Assets 502351827 488765974 1071087 1174701 3242 3364
5 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/governor validator should pass 103830462 83689582 228928 7629
6 Agora/Effects/Governor Mutation Effect/validator/valid new governor datum/effect validator should pass 127968605 97345575 266935 3358
7 Agora/Stake/policy/stakeCreation 59776675 43459609 126049 2116
8 Agora/Stake/validator/stakeDepositWithdraw deposit 276249331 226083166 599197 4024
9 Agora/Stake/validator/stakeDepositWithdraw withdraw 276249331 226083166 599197 4016
10 Agora/Proposal/policy/proposalCreation 34784356 23071177 68894 1523
11 Agora/Proposal/validator/cosignature/proposal 241651391 190181087 511819 5644
12 Agora/Proposal/validator/cosignature/stake 186332635 162540553 402961 4561
13 Agora/Proposal/validator/voting/proposal 240181636 181998338 491168 5652
14 Agora/Proposal/validator/voting/stake 154223940 127693475 328703 4614
15 Agora/Proposal/validator/advancing/successfully advance to next state/Draft -> VotringReady 131365724 98071575 260351 5030
16 Agora/Proposal/validator/advancing/successfully advance to next state/VotingReady -> Locked 130643392 97228153 258848 5039
17 Agora/Proposal/validator/advancing/successfully advance to next state/Locked -> Finished 132128827 98924620 262454 5039
18 Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Draft -> Finished 129853757 96941774 257621 5032
19 Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/VotingReady -> Finished 128636280 95532863 254916 5039
20 Agora/Proposal/validator/advancing/successfully advance to failed state: timeout/Locked -> Finished 129626570 96663841 257320 5039
21 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple 25177457 21017788 55883 806
22 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs 40266637 33204186 88241 900
23 Agora/Treasury/Validator/Positive/Allows for effect changes 37343572 29938856 79744 1841
24 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct simple 25177457 21017788 55883 806
25 Agora/AuthorityToken/singleAuthorityTokenBurned/Correct many inputs 40266637 33204186 88241 900
26 Agora/Governor/policy/GST minting 57978053 43087287 120125 1833
27 Agora/Governor/validator/proposal creation 330344593 258936253 681815 8145
28 Agora/Governor/validator/GATs minting 442720585 358292569 955552 8268 8266
29 Agora/Governor/validator/mutate governor state 101019422 81661538 223202 7686 7682

6243
flake.lock generated
View file

File diff suppressed because it is too large Load diff

475
flake.nix
View file

@ -3,10 +3,19 @@
inputs.nixpkgs.follows = "plutarch/nixpkgs";
inputs.haskell-nix.follows = "plutarch/haskell-nix";
inputs.nixpkgs-latest.url = "github:NixOS/nixpkgs?rev=a0a69be4b5ee63f1b5e75887a406e9194012b492";
# temporary fix for nix versions that have the transitive follows bug
# see https://github.com/NixOS/nix/issues/6013
inputs.nixpkgs-2111 = { url = "github:NixOS/nixpkgs/nixpkgs-21.11-darwin"; };
inputs.haskell-nix-extra-hackage.url = "github:mlabs-haskell/haskell-nix-extra-hackage";
inputs.haskell-nix-extra-hackage.inputs.haskell-nix.follows = "haskell-nix";
inputs.haskell-nix-extra-hackage.inputs.nixpkgs.follows = "nixpkgs";
inputs.iohk-nix.url = "github:input-output-hk/iohk-nix";
inputs.iohk-nix.flake = false;
# Plutarch and its friends
inputs.plutarch.url =
"github:liqwid-labs/plutarch/staging";
@ -18,84 +27,357 @@
inputs.liqwid-plutarch-extra.url =
"git+ssh://git@github.com/Liqwid-Labs/liqwid-plutarch-extra?ref=main";
inputs.plutarch-numeric.url =
"git+ssh://git@github.com/Liqwid-Labs/plutarch-numeric?ref=main";
"git+ssh://git@github.com/Liqwid-Labs/plutarch-numeric?ref=emiflake/bump-plutarch-nix";
inputs.plutarch-safe-money.url =
"git+ssh://git@github.com/Liqwid-Labs/plutarch-safe-money?ref=main";
"git+ssh://git@github.com/Liqwid-Labs/plutarch-safe-money?ref=emiflake/bump-plutarch-nix";
# Testing
inputs.plutarch-quickcheck.url =
"github:liqwid-labs/plutarch-quickcheck?ref=staging";
"github:liqwid-labs/plutarch-quickcheck?ref=emiflake/bump-plutarch";
inputs.plutarch-context-builder.url =
"git+ssh://git@github.com/Liqwid-Labs/plutarch-context-builder?ref=main";
"git+ssh://git@github.com/Liqwid-Labs/plutarch-context-builder?ref=emiflake/bump-plutarch";
# Purescript
inputs.purescript-bridge.url =
"github:mlabs-haskell/purescript-bridge?rev=8e6251e8b1f489748f5bbd9ca6384bcf8cefbbef";
outputs = inputs@{ self, nixpkgs, haskell-nix, plutarch, purescript-bridge, ... }:
# we use sphinxcontrib-haddock input
inputs.plutus.url = "github:input-output-hk/plutus";
# https://github.com/input-output-hk/cardano-prelude/pull/163
inputs.cardano-prelude.url = "github:mlabs-haskell/cardano-prelude?rev=713c7ae79a4d538fcd653c976a652913df1567b9";
inputs.cardano-prelude.flake = false;
inputs.cardano-base.url = "github:input-output-hk/cardano-base";
inputs.cardano-base.flake = false;
inputs.cardano-crypto.url = "github:input-output-hk/cardano-crypto?rev=07397f0e50da97eaa0575d93bee7ac4b2b2576ec";
inputs.cardano-crypto.flake = false;
inputs.haskell-language-server.url = "github:haskell/haskell-language-server";
inputs.haskell-language-server.flake = false;
inputs.secp256k1-haskell.url = "github:haskoin/secp256k1-haskell";
inputs.secp256k1-haskell.flake = false;
# https://github.com/protolude/protolude/pull/133#issuecomment-1112150422 RC not uploaded to hackage yet...
inputs.protolude.url = "github:protolude/protolude";
inputs.protolude.flake = false;
# 0.4.5 hasn't been published to Hackage...
inputs.flat.url = "github:Quid2/flat";
inputs.flat.flake = false;
outputs = inputs@{ self, nixpkgs, nixpkgs-latest, haskell-nix, plutarch, purescript-bridge, haskell-nix-extra-hackage, iohk-nix, ... }:
let
supportedSystems = with nixpkgs.lib.systems.supported;
tier1 ++ tier2 ++ tier3;
perSystem = nixpkgs.lib.genAttrs supportedSystems;
nixpkgsFor = system:
import nixpkgs {
inherit system;
overlays = [ haskell-nix.overlay ];
inherit (haskell-nix) config;
};
nixpkgsFor' = system:
import nixpkgs {
inherit system;
inherit (haskell-nix) config;
pkgsFor = system: import nixpkgs {
inherit system;
overlays = [ haskell-nix.overlay (import "${iohk-nix}/overlays/crypto") ];
# This only does bad things for us...
# inherit (haskell-nix) config;
};
pkgsFor' = system: import nixpkgs-latest { inherit system; };
fourmoluFor = system: (pkgsFor' system).haskell.packages.ghc922.fourmolu_0_6_0_0;
defaultGhcVersion = "ghc923";
isGhc9 = x: builtins.trace "Checking whether ${x} is GHC 9.*" (builtins.substring 3 1 x == "9");
nonReinstallablePkgs = [
"array"
"array"
"base"
"binary"
"bytestring"
"Cabal"
"containers"
"deepseq"
"directory"
"exceptions"
"filepath"
"ghc"
"ghc-bignum"
"ghc-boot"
"ghc-boot"
"ghc-boot-th"
"ghc-compact"
"ghc-heap"
# "ghci"
# "haskeline"
"ghcjs-prim"
"ghcjs-th"
"ghc-prim"
"ghc-prim"
"hpc"
"integer-gmp"
"integer-simple"
"mtl"
"parsec"
"pretty"
"process"
"rts"
"stm"
"template-haskell"
"terminfo"
"text"
"time"
"transformers"
"unix"
"Win32"
"xhtml"
];
haskellModules = [
({ config, pkgs, hsPkgs, ... }: {
inherit nonReinstallablePkgs; # Needed for a lot of different things
packages = {
cardano-binary.doHaddock = false;
cardano-binary.ghcOptions = [ "-Wwarn" ];
cardano-crypto-class.components.library.pkgconfig = pkgs.lib.mkForce [ [ pkgs.libsodium-vrf ] ];
cardano-crypto-class.doHaddock = false;
cardano-crypto-class.ghcOptions = [ "-Wwarn" ];
cardano-crypto-praos.components.library.pkgconfig = pkgs.lib.mkForce [ [ pkgs.libsodium-vrf ] ];
cardano-prelude.doHaddock = false; # somehow above options are not applied?
cardano-prelude.ghcOptions = [ "-Wwarn" ];
# Workaround missing support for build-tools:
# https://github.com/input-output-hk/haskell.nix/issues/231
plutarch-test.components.exes.plutarch-test.build-tools = [
config.hsPkgs.hspec-discover
];
};
})
];
myhackage = system: compiler-nix-name: haskell-nix-extra-hackage.mkHackageFor system compiler-nix-name (
[
"${inputs.flat}"
"${inputs.protolude}"
"${inputs.cardano-prelude}/cardano-prelude"
"${inputs.cardano-crypto}"
"${inputs.cardano-base}/binary"
"${inputs.cardano-base}/cardano-crypto-class"
"${inputs.plutus}/plutus-core"
"${inputs.plutus}/plutus-ledger-api"
"${inputs.plutus}/plutus-tx"
"${inputs.plutus}/prettyprinter-configurable"
"${inputs.plutus}/word-array"
"${inputs.secp256k1-haskell}"
"${inputs.plutus}/plutus-tx-plugin" # necessary for FFI tests
# Custom deps as a consumer
"${inputs.plutarch}"
"${inputs.plutarch}/plutarch-extra"
"${inputs.liqwid-plutarch-extra}"
"${inputs.plutarch-numeric}"
"${inputs.plutarch-safe-money}"
"${inputs.plutarch-quickcheck}"
"${inputs.plutarch-context-builder}"
]
);
applyPlutarchDep = pkgs: o:
let h = myhackage pkgs.system o.compiler-nix-name; in
o // {
modules = haskellModules ++ [ h.module ] ++ (o.modules or [ ]);
extra-hackages = [ (import h.hackageNix) ] ++ (o.extra-hackages or [ ]);
extra-hackage-tarballs = { _xNJUd_plutarch-hackage = h.hackageTarball; } // (o.extra-hackage-tarballs or { });
cabalProjectLocal = (o.cabalProjectLocal or "") + (
''
allow-newer:
cardano-binary:base
, cardano-crypto-class:base
, cardano-prelude:base
, canonical-json:bytestring
, plutus-core:ral
, plutus-core:some
, int-cast:base
, inline-r:singletons
constraints:
OneTuple >= 0.3.1
, Only >= 0.1
, QuickCheck >= 2.14.2
, StateVar >= 1.2.2
, Stream >= 0.4.7.2
, adjunctions >= 4.4
, aeson >= 2.0.3.0
, algebraic-graphs >= 0.6
, ansi-terminal >= 0.11.1
, ansi-wl-pprint >= 0.6.9
, assoc >= 1.0.2
, async >= 2.2.4
, attoparsec >= 0.14.4
, barbies >= 2.0.3.1
, base-compat >= 0.12.1
, base-compat-batteries >= 0.12.1
, base-orphans >= 0.8.6
, base16-bytestring >= 1.0.2.0
, basement >= 0.0.12
, bifunctors >= 5.5.11
, bimap >= 0.4.0
, bin >= 0.1.2
, boring >= 0.2
, boxes >= 0.1.5
, cabal-doctest >= 1.0.9
, call-stack >= 0.4.0
, canonical-json >= 0.6.0.0
, cardano-binary >= 1.5.0
, cardano-crypto >= 1.1.0
, cardano-crypto-class >= 2.0.0
, cardano-prelude >= 0.1.0.0
, case-insensitive >= 1.2.1.0
, cassava >= 0.5.2.0
, cborg >= 0.2.6.0
, clock >= 0.8.2
, colour >= 2.3.6
, comonad >= 5.0.8
, composition-prelude >= 3.0.0.2
, concurrent-output >= 1.10.14
, constraints >= 0.13.2
, constraints-extras >= 0.3.2.1
, contravariant >= 1.5.5
, cryptonite >= 0.29
, data-default >= 0.7.1.1
, data-default-class >= 0.1.2.0
, data-default-instances-containers >= 0.0.1
, data-default-instances-dlist >= 0.0.1
, data-default-instances-old-locale >= 0.0.1
, data-fix >= 0.3.2
, dec >= 0.0.4
, dependent-map >= 0.4.0.0
, dependent-sum >= 0.7.1.0
, dependent-sum-template >= 0.1.1.1
, deriving-aeson >= 0.2.8
, deriving-compat >= 0.6
, dictionary-sharing >= 0.1.0.0
, distributive >= 0.6.2.1
, dlist >= 1.0
, dom-lt >= 0.2.3
, double-conversion >= 2.0.2.0
, erf >= 2.0.0.0
, exceptions >= 0.10.4
, extra >= 1.7.10
, fin >= 0.2.1
, flat >= 0.4.5
, foldl >= 1.4.12
, formatting >= 7.1.3
, foundation >= 0.0.26.1
, free >= 5.1.7
, half >= 0.3.1
, hashable >= 1.4.0.2
, haskell-lexer >= 1.1
, hedgehog >= 1.0.5
, indexed-traversable >= 0.1.2
, indexed-traversable-instances >= 0.1.1
, integer-logarithms >= 1.0.3.1
, invariant >= 0.5.5
, kan-extensions >= 5.2.3
, lazy-search >= 0.1.2.1
, lazysmallcheck >= 0.6
, lens >= 5.1
, lifted-async >= 0.10.2.2
, lifted-base >= 0.2.3.12
, list-t >= 1.0.5.1
, logict >= 0.7.0.3
, megaparsec >= 9.2.0
, memory >= 0.16.0
, microlens >= 0.4.12.0
, mmorph >= 1.2.0
, monad-control >= 1.0.3.1
, mono-traversable >= 1.0.15.3
, monoidal-containers >= 0.6.2.0
, mtl-compat >= 0.2.2
, newtype >= 0.2.2.0
, newtype-generics >= 0.6.1
, nothunks >= 0.1.3
, old-locale >= 1.0.0.7
, old-time >= 1.1.0.3
, optparse-applicative >= 0.16.1.0
, parallel >= 3.2.2.0
, parser-combinators >= 1.3.0
, plutus-core >= 0.1.0.0
, plutus-ledger-api >= 0.1.0.0
, plutus-tx >= 0.1.0.0
, pretty-show >= 1.10
, prettyprinter >= 1.7.1
, prettyprinter-configurable >= 0.1.0.0
, primitive >= 0.7.3.0
, profunctors >= 5.6.2
, protolude >= 0.3.0
, quickcheck-instances >= 0.3.27
, ral >= 0.2.1
, random >= 1.2.1
, rank2classes >= 1.4.4
, recursion-schemes >= 5.2.2.2
, reflection >= 2.1.6
, resourcet >= 1.2.4.3
, safe >= 0.3.19
, safe-exceptions >= 0.1.7.2
, scientific >= 0.3.7.0
, semialign >= 1.2.0.1
, semigroupoids >= 5.3.7
, semigroups >= 0.20
, serialise >= 0.2.4.0
, size-based >= 0.1.2.0
, some >= 1.0.3
, split >= 0.2.3.4
, splitmix >= 0.1.0.4
, stm >= 2.5.0.0
, strict >= 0.4.0.1
, syb >= 0.7.2.1
, tagged >= 0.8.6.1
, tasty >= 1.4.2.1
, tasty-golden >= 2.3.5
, tasty-hedgehog >= 1.1.0.0
, tasty-hunit >= 0.10.0.3
, temporary >= 1.3
, terminal-size >= 0.3.2.1
, testing-type-modifiers >= 0.1.0.1
, text-short >= 0.1.5
, th-abstraction >= 0.4.3.0
, th-compat >= 0.1.3
, th-expand-syns >= 0.4.9.0
, th-extras >= 0.0.0.6
, th-lift >= 0.8.2
, th-lift-instances >= 0.1.19
, th-orphans >= 0.13.12
, th-reify-many >= 0.1.10
, th-utilities >= 0.2.4.3
, these >= 1.1.1.1
, time-compat >= 1.9.6.1
, transformers-base >= 0.4.6
, transformers-compat >= 0.7.1
, type-equality >= 1
, typed-process >= 0.2.8.0
, unbounded-delays >= 0.1.1.1
, universe-base >= 1.1.3
, unliftio-core >= 0.2.0.1
, unordered-containers >= 0.2.16.0
, uuid-types >= 1.0.5
, vector >= 0.12.3.1
, vector-algorithms >= 0.8.0.4
, void >= 0.7.3
, wcwidth >= 0.0.2
, witherable >= 0.4.2
, wl-pprint-annotated >= 0.1.0.1
, word-array >= 0.1.0.0
, secp256k1-haskell >= 0.6
, inline-r >= 0.10.5
, plutarch-extra >= 1.0.0
, plutarch-quickcheck >= 1.0.0
''
);
};
ghcVersion = "ghc921";
projectFor = system:
let pkgs = nixpkgsFor system;
in
let pkgs' = nixpkgsFor' system;
in
(nixpkgsFor system).haskell-nix.cabalProject' {
projectForGhc = compiler-nix-name: system:
let pkgs = pkgsFor system; in
let pkgs' = pkgsFor' system; in
let pkgSet = pkgs.haskell-nix.cabalProject' (applyPlutarchDep pkgs {
src = ./.;
compiler-nix-name = ghcVersion;
inherit (plutarch) cabalProjectLocal;
extraSources = plutarch.extraSources ++ [
{
src = inputs.plutarch;
subdirs = [
"."
"plutarch-extra"
];
}
{
src = inputs.liqwid-plutarch-extra;
subdirs = [ "." ];
}
{
src = inputs.plutarch-numeric;
subdirs = [ "." ];
}
{
src = inputs.plutarch-safe-money;
subdirs = [ "." ];
}
{
src = inputs.plutarch-quickcheck;
subdirs = [ "." ];
}
{
src = inputs.plutarch-context-builder;
subdirs = [ "." ];
}
{
src = inputs.purescript-bridge;
subdirs = [ "." ];
}
];
modules = [ (plutarch.haskellModule system) ];
inherit compiler-nix-name;
modules = [ ];
shell = {
withHoogle = true;
@ -103,58 +385,28 @@
# We use the ones from Nixpkgs, since they are cached reliably.
# Eventually we will probably want to build these with haskell.nix.
nativeBuildInputs = with pkgs'; [
entr
haskellPackages.apply-refact
git
fd
cabal-install
haskell.packages."${ghcVersion}".hlint
haskellPackages.cabal-fmt
nixpkgs-fmt
graphviz
];
inherit (plutarch) tools;
additional = ps: [
# plutarch
ps.plutarch
ps.liqwid-plutarch-extra
ps.plutarch-numeric
ps.plutarch-safe-money
# purescript
ps.purescript-bridge
# testing
ps.tasty-quickcheck
ps.plutarch-quickcheck
ps.plutarch-context-builder
nativeBuildInputs = [
pkgs'.cabal-install
pkgs'.hlint
pkgs'.haskellPackages.cabal-fmt
(fourmoluFor system)
pkgs'.nixpkgs-fmt
(plutarch.hlsFor compiler-nix-name system)
];
};
};
}); in
pkgSet;
projectFor = projectForGhc defaultGhcVersion;
projectFor810 = projectForGhc "ghc8107";
formatCheckFor = system:
let
pkgs = nixpkgsFor system;
pkgs' = nixpkgsFor' system;
inherit (pkgs.haskell-nix.tools ghcVersion {
inherit (plutarch.tools) fourmolu;
})
fourmolu;
pkgs' = pkgsFor' system;
in
pkgs.runCommand "format-check"
pkgs'.runCommand "format-check"
{
nativeBuildInputs = [
pkgs'.git
pkgs'.fd
pkgs'.haskellPackages.cabal-fmt
pkgs'.nixpkgs-fmt
fourmolu
pkgs'.haskell.packages."${ghcVersion}".hlint
];
nativeBuildInputs = [ pkgs'.haskellPackages.cabal-fmt pkgs'.nixpkgs-fmt (fourmoluFor system) pkgs'.hlint ];
} ''
export LC_CTYPE=C.UTF-8
export LC_ALL=C.UTF-8
@ -163,12 +415,13 @@
make format_check || (echo " Please run 'make format'" ; exit 1)
find -name '*.hs' -not -path './dist*/*' -not -path './haddock/*' | xargs hlint
mkdir $out
'';
''
;
benchCheckFor = system: agora-bench:
let
pkgs = nixpkgsFor system;
pkgs' = nixpkgsFor' system;
pkgs = pkgsFor system;
pkgs' = pkgsFor' system;
in
pkgs.runCommand "bench-check"
{
@ -184,7 +437,6 @@
make bench_check || (echo " Please run 'make bench'" ; exit 1)
mkdir $out
'';
in
{
project = perSystem projectFor;
@ -195,7 +447,7 @@
haddock =
let
agora-doc = self.flake.${system}.packages."agora:lib:agora".doc;
pkgs = nixpkgsFor system;
pkgs = pkgsFor system;
in
pkgs.runCommand "haddock-merge" { } ''
cd ${self}
@ -208,12 +460,13 @@
checks = perSystem (system:
self.flake.${system}.checks // {
formatCheck = formatCheckFor system;
benchCheck = benchCheckFor system self.flake.${system}.packages."agora:bench:agora-bench";
# benchCheck = benchCheckFor system self.flake.${system}.packages."agora:bench:agora-bench";
agora = self.flake.${system}.packages."agora:lib:agora";
agora-test = self.flake.${system}.packages."agora:test:agora-test";
benchCheck = benchCheckFor system self.flake.${system}.packages."agora:bench:agora-bench";
});
check = perSystem (system:
(nixpkgsFor system).runCommand "combined-test"
(pkgsFor system).runCommand "combined-test"
{
checksss = builtins.attrValues self.checks.${system};
} ''