Merge branch 'master' into emiflake/stake
This commit is contained in:
commit
c6e7d15652
7 changed files with 51 additions and 4 deletions
|
|
@ -138,3 +138,12 @@ test-suite agora-test
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
|
|
||||||
|
benchmark agora-bench
|
||||||
|
import: lang, deps
|
||||||
|
hs-source-dirs: bench
|
||||||
|
main-is: Main.hs
|
||||||
|
type: exitcode-stdio-1.0
|
||||||
|
build-depends:
|
||||||
|
, plutarch-benchmark
|
||||||
|
, agora
|
||||||
3
bench.csv
Normal file
3
bench.csv
Normal file
|
|
@ -0,0 +1,3 @@
|
||||||
|
name,cpu,mem,size
|
||||||
|
full_scripts:authorityTokenPolicy,1280339,4400,276
|
||||||
|
full_scripts:stakePolicy,2649897,9000,786
|
||||||
|
28
bench/Main.hs
Normal file
28
bench/Main.hs
Normal file
|
|
@ -0,0 +1,28 @@
|
||||||
|
module Main (main) where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
import Plutarch.Benchmark
|
||||||
|
import Plutus.V1.Ledger.Value qualified as Value
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
import Agora.AuthorityToken qualified as Agora
|
||||||
|
import Agora.SafeMoney qualified as Agora
|
||||||
|
import Agora.Stake qualified as Agora
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
benchMain benchmarks
|
||||||
|
|
||||||
|
benchmarks :: [NamedBenchmark]
|
||||||
|
benchmarks =
|
||||||
|
benchGroup
|
||||||
|
"full_scripts"
|
||||||
|
[ bench "authorityTokenPolicy" $ Agora.authorityTokenPolicy (Agora.AuthorityToken (Value.assetClass "" ""))
|
||||||
|
, bench "stakePolicy" $ Agora.stakePolicy (Agora.Stake @Agora.LQ)
|
||||||
|
]
|
||||||
|
|
@ -1,3 +1,4 @@
|
||||||
packages: ./.
|
packages: ./.
|
||||||
|
|
||||||
|
benchmarks: true
|
||||||
tests: true
|
tests: true
|
||||||
|
|
|
||||||
|
|
@ -42,7 +42,7 @@
|
||||||
inherit (plutarch) cabalProjectLocal;
|
inherit (plutarch) cabalProjectLocal;
|
||||||
extraSources = plutarch.extraSources ++ [{
|
extraSources = plutarch.extraSources ++ [{
|
||||||
src = inputs.plutarch;
|
src = inputs.plutarch;
|
||||||
subdirs = [ "." ];
|
subdirs = [ "." "plutarch-benchmark" ];
|
||||||
}];
|
}];
|
||||||
modules = [ (plutarch.haskellModule system) ];
|
modules = [ (plutarch.haskellModule system) ];
|
||||||
shell = {
|
shell = {
|
||||||
|
|
@ -64,7 +64,11 @@
|
||||||
|
|
||||||
inherit (plutarch) tools;
|
inherit (plutarch) tools;
|
||||||
|
|
||||||
additional = ps: [ ps.plutarch ps.tasty-quickcheck ];
|
additional = ps: [
|
||||||
|
ps.plutarch
|
||||||
|
ps.plutarch-benchmark
|
||||||
|
ps.tasty-quickcheck
|
||||||
|
];
|
||||||
};
|
};
|
||||||
};
|
};
|
||||||
|
|
||||||
|
|
|
||||||
2
hie.yaml
2
hie.yaml
|
|
@ -2,5 +2,7 @@ cradle:
|
||||||
cabal:
|
cabal:
|
||||||
- path: "./src"
|
- path: "./src"
|
||||||
component: "lib:agora"
|
component: "lib:agora"
|
||||||
|
- path: "./bench"
|
||||||
|
component: "benchmark:agora-bench"
|
||||||
- path: "./test"
|
- path: "./test"
|
||||||
component: "test:agora-test"
|
component: "test:agora-test"
|
||||||
|
|
|
||||||
|
|
@ -103,15 +103,15 @@ stakePolicy _stake =
|
||||||
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
ctx <- pletFields @'["txInfo", "purpose"] ctx'
|
||||||
|
|
||||||
PMinting ownSymbol <- pmatch $ pfromData ctx.purpose
|
PMinting ownSymbol <- pmatch $ pfromData ctx.purpose
|
||||||
-- TODO: add this to 'valueCorrect'
|
|
||||||
let stValue = psingletonValue # (pfield @"_0" # ownSymbol) # pconstant "ST" # 1
|
let stValue = psingletonValue # (pfield @"_0" # ownSymbol) # pconstant "ST" # 1
|
||||||
|
|
||||||
passert "A UTXO must exist with the correct output" $
|
passert "A UTXO must exist with the correct output" $
|
||||||
anyOutput @(StakeDatum gt) # pfromData ctx.txInfo
|
anyOutput @(StakeDatum gt) # pfromData ctx.txInfo
|
||||||
# ( plam $ \value stakeDatum' -> P.do
|
# ( plam $ \value stakeDatum' -> P.do
|
||||||
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
stakeDatum <- pletFields @'["owner", "stakedAmount"] stakeDatum'
|
||||||
|
let expectedValue = paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue
|
||||||
let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner
|
let ownerSignsTransaction = ptxSignedBy # ctx.txInfo # stakeDatum.owner
|
||||||
let valueCorrect = pdata value #== pdata (paddValue # (discreteValue # stakeDatum.stakedAmount) # stValue)
|
let valueCorrect = pdata value #== pdata expectedValue
|
||||||
ownerSignsTransaction #&& valueCorrect
|
ownerSignsTransaction #&& valueCorrect
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue