Skip to content

Commit de099a8

Browse files
zliu41zliu41
committed
Add some golden tests on data-backed ScriptContext
1 parent 5458fe5 commit de099a8

File tree

7 files changed

+305
-1
lines changed

7 files changed

+305
-1
lines changed

‎plutus-ledger-api/plutus-ledger-api.cabal‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -214,6 +214,7 @@ test-suite plutus-ledger-api-plugin-test
214214
other-modules:
215215
Spec.Budget
216216
Spec.Data.Budget
217+
Spec.Data.ScriptContext
217218
Spec.Data.Value
218219
Spec.MintValue.V3
219220
Spec.ReturnUnit.V1
@@ -224,7 +225,7 @@ test-suite plutus-ledger-api-plugin-test
224225
Spec.Value.WithCurrencySymbol
225226

226227
if os(windows)
227-
buildable: False
228+
buildable: False
228229

229230
build-depends:
230231
, base >=4.9 && <5

‎plutus-ledger-api/test-plugin/Spec.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@ module Main where
22

33
import Spec.Budget qualified
44
import Spec.Data.Budget qualified
5+
import Spec.Data.ScriptContext qualified
56
import Spec.Data.Value qualified
67
import Spec.MintValue.V3 qualified
78
import Spec.ReturnUnit.V1 qualified
@@ -22,6 +23,7 @@ tests =
2223
"plutus-ledger-api-plugin-test"
2324
[ Spec.Budget.tests
2425
, Spec.Data.Budget.tests
26+
, Spec.Data.ScriptContext.tests
2527
, Spec.Data.Value.test_EqValue
2628
, Spec.ReturnUnit.V1.tests
2729
, Spec.ReturnUnit.V2.tests

‎plutus-ledger-api/test-plugin/Spec/Data/ScriptContext.hs‎

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,53 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE MultiParamTypeClasses #-}
6+
{-# LANGUAGE NegativeLiterals #-}
7+
{-# LANGUAGE OverloadedStrings #-}
8+
{-# LANGUAGE PatternSynonyms #-}
9+
{-# LANGUAGE TemplateHaskell #-}
10+
{-# LANGUAGE ViewPatterns #-}
11+
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-}
12+
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
13+
14+
module Spec.Data.ScriptContext where
15+
16+
import Test.Tasty (TestTree)
17+
import Test.Tasty.Extras
18+
19+
import PlutusLedgerApi.Data.V3 qualified as V3D
20+
import PlutusTx.Builtins qualified as PlutusTx
21+
import PlutusTx.Code
22+
import PlutusTx.IsData qualified as PlutusTx
23+
import PlutusTx.Prelude qualified as PlutusTx
24+
import PlutusTx.Test
25+
import PlutusTx.TH (compile)
26+
27+
tests :: TestTree
28+
tests =
29+
runTestNested ["test-plugin", "Spec", "Data", "SriptContext"] . pure . testNestedGhc $
30+
[ goldenPirReadable "alwaysSucceeds" compiledAlwaysSucceeds
31+
, goldenUPlcReadable "alwaysSucceeds" compiledAlwaysSucceeds
32+
, goldenPirReadable "succeedsIfHasDatum" compiledSucceedsIfHasDatum
33+
, goldenUPlcReadable "succeedsIfHasDatum" compiledSucceedsIfHasDatum
34+
]
35+
36+
alwaysSucceeds :: PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit
37+
alwaysSucceeds d =
38+
PlutusTx.check $
39+
case PlutusTx.unsafeFromBuiltinData d of
40+
V3D.ScriptContext _ _ _ -> True
41+
42+
succeedsIfHasDatum :: PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit
43+
succeedsIfHasDatum d =
44+
PlutusTx.check $
45+
case PlutusTx.unsafeFromBuiltinData d of
46+
V3D.ScriptContext _ _ (V3D.SpendingScript _ (Just _)) -> True
47+
_ -> False
48+
49+
compiledAlwaysSucceeds :: CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit)
50+
compiledAlwaysSucceeds = $$(compile [||alwaysSucceeds||])
51+
52+
compiledSucceedsIfHasDatum :: CompiledCode (PlutusTx.BuiltinData -> PlutusTx.BuiltinUnit)
53+
compiledSucceedsIfHasDatum = $$(compile [||succeedsIfHasDatum||])

‎plutus-ledger-api/test-plugin/Spec/Data/SriptContext/9.6/alwaysSucceeds.pir.golden‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
let
2+
data Bool | Bool_match where
3+
True : Bool
4+
False : Bool
5+
data Unit | Unit_match where
6+
Unit : Unit
7+
in
8+
\(d : data) ->
9+
Bool_match
10+
(let
11+
!tup : pair integer (list data) = unConstrData d
12+
in
13+
Bool_match
14+
(ifThenElse
15+
{Bool}
16+
(equalsInteger 0 (fstPair {integer} {list data} tup))
17+
True
18+
False)
19+
{all dead. Bool}
20+
(/\dead ->
21+
let
22+
!l : list data = sndPair {integer} {list data} tup
23+
!l : list data = tailList {data} l
24+
!ds : data = headList {data} l
25+
!ds : data = headList {data} l
26+
!ds : data = headList {data} (tailList {data} l)
27+
in
28+
True)
29+
(/\dead -> Unit_match (error {Unit}) {Bool} (error {Bool}))
30+
{all dead. dead})
31+
{all dead. unit}
32+
(/\dead -> ())
33+
(/\dead -> error {unit})
34+
{all dead. dead}

‎plutus-ledger-api/test-plugin/Spec/Data/SriptContext/9.6/alwaysSucceeds.uplc.golden‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
(program
2+
1.1.0
3+
(\d ->
4+
force
5+
(case
6+
((\tup ->
7+
force
8+
(force
9+
(force ifThenElse
10+
(equalsInteger 0 (force (force fstPair) tup))
11+
(delay
12+
(delay
13+
((\l ->
14+
(\l ->
15+
(\ds ->
16+
(\ds ->
17+
(\ds -> constr 0 [])
18+
(force headList (force tailList l)))
19+
(force headList l))
20+
(force headList l))
21+
(force tailList l))
22+
(force (force sndPair) tup))))
23+
(delay (delay (case error [error]))))))
24+
(unConstrData d))
25+
[(delay ()), (delay error)])))

‎plutus-ledger-api/test-plugin/Spec/Data/SriptContext/9.6/succeedsIfHasDatum.pir.golden‎

Lines changed: 80 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,80 @@
1+
let
2+
data (Maybe :: * -> *) a | Maybe_match where
3+
Just : a -> Maybe a
4+
Nothing : Maybe a
5+
data Bool | Bool_match where
6+
True : Bool
7+
False : Bool
8+
data Unit | Unit_match where
9+
Unit : Unit
10+
!traceError : all a. string -> a
11+
= /\a ->
12+
\(str : string) -> let !x : Unit = trace {Unit} str Unit in error {a}
13+
in
14+
\(d : data) ->
15+
Bool_match
16+
(let
17+
!tup : pair integer (list data) = unConstrData d
18+
in
19+
Bool_match
20+
(ifThenElse
21+
{Bool}
22+
(equalsInteger 0 (fstPair {integer} {list data} tup))
23+
True
24+
False)
25+
{all dead. Bool}
26+
(/\dead ->
27+
let
28+
!l : list data = sndPair {integer} {list data} tup
29+
!l : list data = tailList {data} l
30+
!ds : data = headList {data} l
31+
!ds : data = headList {data} l
32+
!tup : pair integer (list data)
33+
= unConstrData (headList {data} (tailList {data} l))
34+
in
35+
Bool_match
36+
(ifThenElse
37+
{Bool}
38+
(equalsInteger 1 (fstPair {integer} {list data} tup))
39+
True
40+
False)
41+
{all dead. Bool}
42+
(/\dead ->
43+
let
44+
!l : list data = sndPair {integer} {list data} tup
45+
!ds : data = headList {data} l
46+
!ds : Maybe data
47+
= let
48+
!tup : pair integer (list data)
49+
= unConstrData (headList {data} (tailList {data} l))
50+
!index : integer = fstPair {integer} {list data} tup
51+
!args : list data = sndPair {integer} {list data} tup
52+
in
53+
Bool_match
54+
(ifThenElse {Bool} (equalsInteger 1 index) True False)
55+
{all dead. Maybe data}
56+
(/\dead -> Nothing {data})
57+
(/\dead ->
58+
Bool_match
59+
(ifThenElse {Bool} (equalsInteger 0 index) True False)
60+
{all dead. Maybe data}
61+
(/\dead -> Just {data} (headList {data} args))
62+
(/\dead -> traceError {Maybe data} "PT1")
63+
{all dead. dead})
64+
{all dead. dead}
65+
in
66+
Maybe_match
67+
{data}
68+
ds
69+
{all dead. Bool}
70+
(\(ds : data) -> /\dead -> True)
71+
(/\dead -> False)
72+
{all dead. dead})
73+
(/\dead -> False)
74+
{all dead. dead})
75+
(/\dead -> False)
76+
{all dead. dead})
77+
{all dead. unit}
78+
(/\dead -> ())
79+
(/\dead -> traceError {unit} "PT5")
80+
{all dead. dead}

‎plutus-ledger-api/test-plugin/Spec/Data/SriptContext/9.6/succeedsIfHasDatum.uplc.golden‎

Lines changed: 109 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,109 @@
1+
(program
2+
1.1.0
3+
(\d ->
4+
force
5+
((\traceError ->
6+
case
7+
((\tup ->
8+
force
9+
(force
10+
(force
11+
ifThenElse
12+
(equalsInteger 0 (force (force fstPair) tup))
13+
(delay
14+
(delay
15+
((\l ->
16+
(\l ->
17+
(\ds ->
18+
(\ds ->
19+
(\tup ->
20+
force
21+
(force
22+
(force
23+
ifThenElse
24+
(equalsInteger
25+
1
26+
(force
27+
(force fstPair)
28+
tup))
29+
(delay
30+
(delay
31+
((\l ->
32+
(\ds ->
33+
force
34+
(case
35+
((\tup ->
36+
(\index ->
37+
(\args ->
38+
force
39+
(force
40+
(force
41+
ifThenElse
42+
(equalsInteger
43+
1
44+
index)
45+
(delay
46+
(delay
47+
(constr 1
48+
[ ])))
49+
(delay
50+
(delay
51+
(force
52+
(force
53+
(force
54+
ifThenElse
55+
(equalsInteger
56+
0
57+
index)
58+
(delay
59+
(delay
60+
(constr 0
61+
[ (force
62+
headList
63+
args) ])))
64+
(delay
65+
(delay
66+
(traceError
67+
"PT1")))))))))))
68+
(force
69+
(force
70+
sndPair)
71+
tup))
72+
(force
73+
(force
74+
fstPair)
75+
tup))
76+
(unConstrData
77+
(force
78+
headList
79+
(force
80+
tailList
81+
l))))
82+
[ (\ds ->
83+
delay
84+
(constr 0
85+
[ ]))
86+
, (delay
87+
(constr 1
88+
[ ])) ]))
89+
(force
90+
headList
91+
l))
92+
(force
93+
(force
94+
sndPair)
95+
tup))))
96+
(delay
97+
(delay
98+
(constr 1 []))))))
99+
(unConstrData
100+
(force headList
101+
(force tailList l))))
102+
(force headList l))
103+
(force headList l))
104+
(force tailList l))
105+
(force (force sndPair) tup))))
106+
(delay (delay (constr 1 []))))))
107+
(unConstrData d))
108+
[(delay ()), (delay (traceError "PT5"))])
109+
(\str -> (\x -> error) (force trace str (constr 0 []))))))

0 commit comments

Comments
 (0)