Skip to content

Commit

Permalink
manual pattern synonym
Browse files Browse the repository at this point in the history
  • Loading branch information
@zliu41
zliu41 committed Jan 17, 2025
1 parent 23c0e64 commit b31eab9
Show file tree
Hide file tree
Showing 6 changed files with 195 additions and 0 deletions.
2 changes: 2 additions & 0 deletions plutus-tx-plugin/test/AsData/Budget/9.6/patternMatchingManual-budget.budget.golden
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
({cpu: 4839211
| mem: 17142})
1 change: 1 addition & 0 deletions plutus-tx-plugin/test/AsData/Budget/9.6/patternMatchingManual.eval.golden
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
(con integer 220)
77 changes: 77 additions & 0 deletions plutus-tx-plugin/test/AsData/Budget/9.6/patternMatchingManual.pir.golden
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,77 @@
let
data Unit | Unit_match where
Unit : Unit
!addInteger : integer -> integer -> integer
= \(x : integer) (y : integer) -> addInteger x y
data Bool | Bool_match where
True : Bool
False : Bool
!lessThanInteger : integer -> integer -> Bool
= \(x : integer) (y : integer) ->
ifThenElse {Bool} (lessThanInteger x y) True False
data (Tuple4 :: * -> * -> * -> * -> *) a b c d | Tuple4_match where
Tuple4 : a -> b -> c -> d -> Tuple4 a b c d
in
\(d : data) ->
Tuple4_match
{integer}
{integer}
{integer}
{integer}
((let
r = Tuple4 integer integer integer integer
in
\(scrut : data)
(cont : integer -> integer -> integer -> integer -> r)
(fail : unit -> r) ->
Tuple4_match
{integer}
{integer}
{integer}
{integer}
(let
!ds : list data
= sndPair {integer} {list data} (unConstrData scrut)
!ds : list data = tailList {data} ds
!ds : list data = tailList {data} ds
!w : integer = unIData (headList {data} (tailList {data} ds))
!z : integer = unIData (headList {data} ds)
!y : integer = unIData (headList {data} ds)
in
Tuple4
{integer}
{integer}
{integer}
{integer}
(unIData (headList {data} ds))
y
z
w)
{r}
(\(x : integer) (y : integer) (z : integer) (w : integer) ->
cont x y z w))
d
(\(x : integer) (y : integer) (z : integer) (w : integer) ->
Tuple4 {integer} {integer} {integer} {integer} x y z w)
(\(void : unit) ->
Unit_match
(error {Unit})
{Tuple4 integer integer integer integer}
(error {Tuple4 integer integer integer integer})))
{integer}
(\(ipv : integer) (ipv : integer) (ipv : integer) (ipv : integer) ->
addInteger
(addInteger
(addInteger (addInteger (addInteger ipv ipv) ipv) ipv)
(Bool_match
(lessThanInteger (addInteger ipv ipv) (addInteger ipv ipv))
{all dead. integer}
(/\dead -> addInteger ipv ipv)
(/\dead -> addInteger ipv ipv)
{all dead. dead}))
(Bool_match
(lessThanInteger (addInteger ipv ipv) (addInteger ipv ipv))
{all dead. integer}
(/\dead -> addInteger ipv ipv)
(/\dead -> addInteger ipv ipv)
{all dead. dead}))
43 changes: 43 additions & 0 deletions plutus-tx-plugin/test/AsData/Budget/9.6/patternMatchingManual.uplc.golden
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,43 @@
(program
1.1.0
(\d ->
case
(case
((\ds ->
(\ds ->
(\ds ->
(\w ->
(\z ->
(\y ->
constr 0 [(unIData (force headList ds)), y, z, w])
(unIData (force headList ds)))
(unIData (force headList ds)))
(unIData (force headList (force tailList ds))))
(force tailList ds))
(force tailList ds))
(force (force sndPair) (unConstrData d)))
[(\x y z w -> constr 0 [x, y, z, w])])
[ (\ipv ipv ipv ipv ->
(\lessThanInteger ->
addInteger
(addInteger
(addInteger (addInteger (addInteger ipv ipv) ipv) ipv)
(force
(case
(lessThanInteger
(addInteger ipv ipv)
(addInteger ipv ipv))
[ (delay (addInteger ipv ipv))
, (delay (addInteger ipv ipv)) ])))
(force
(case
(lessThanInteger
(addInteger ipv ipv)
(addInteger ipv ipv))
[ (delay (addInteger ipv ipv))
, (delay (addInteger ipv ipv)) ])))
(\x y ->
force ifThenElse
(lessThanInteger x y)
(constr 0 [])
(constr 1 []))) ]))
33 changes: 33 additions & 0 deletions plutus-tx-plugin/test/AsData/Budget/Spec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,10 @@ tests =
, goldenUPlcReadable "patternMatching" patternMatching
, goldenEvalCekCatch "patternMatching" [patternMatching `unsafeApplyCode` inp]
, goldenBudget "patternMatching-budget" (patternMatching `unsafeApplyCode` inp)
, goldenPirReadable "patternMatchingManual" patternMatchingManual
, goldenUPlcReadable "patternMatchingManual" patternMatchingManual
, goldenEvalCekCatch "patternMatchingManual" [patternMatchingManual `unsafeApplyCode` inp]
, goldenBudget "patternMatchingManual-budget" (patternMatchingManual `unsafeApplyCode` inp)
, goldenPirReadable "recordFields" recordFields
, goldenUPlcReadable "recordFields" recordFields
, goldenEvalCekCatch "recordFields" [recordFields `unsafeApplyCode` inp]
Expand Down Expand Up @@ -77,6 +81,35 @@ patternMatching =
||]
)

patternMatchingManual :: CompiledCode (PlutusTx.BuiltinData -> Integer)
patternMatchingManual =
$$( compile
[||
\d ->
let (IntsManualPattern x0 y0 z0 w0) = PlutusTx.unsafeFromBuiltinData d
x = x0
y = y0
z = z0
w = w0
in x
`PlutusTx.addInteger` y
`PlutusTx.addInteger` z
`PlutusTx.addInteger` w
`PlutusTx.addInteger` ( if PlutusTx.lessThanInteger
(y `PlutusTx.addInteger` z)
(x `PlutusTx.addInteger` w)
then x `PlutusTx.addInteger` z
else y `PlutusTx.addInteger` w
)
`PlutusTx.addInteger` ( if PlutusTx.lessThanInteger
(z `PlutusTx.addInteger` y)
(w `PlutusTx.addInteger` x)
then z `PlutusTx.addInteger` x
else w `PlutusTx.addInteger` y
)
||]
)

recordFields :: CompiledCode (PlutusTx.BuiltinData -> Integer)
recordFields =
$$( compile
Expand Down
39 changes: 39 additions & 0 deletions plutus-tx-plugin/test/AsData/Budget/Types.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -37,6 +37,45 @@ newtype IntsManual = IntsManual PlutusTx.BuiltinData
, PlutusTx.ToData
)

pattern IntsManualPattern :: Integer -> Integer -> Integer -> Integer -> IntsManual
pattern IntsManualPattern x y z w <- IntsManual (unpackIntsManual -> (x, y, z, w))
where
IntsManualPattern x y z w = IntsManual (packIntsManual x y z w)

-- Improvements over the TH-generated pattern synonym:
-- 1. Since this is a product type, there's no need to check `BI.fst tup == 0`
-- 2. Don't use `pairToPair` or `unsafeUncons`, since they construct non-builtin pairs.
unpackIntsManual :: PlutusTx.BuiltinData -> (Integer, Integer, Integer, Integer)
unpackIntsManual d =
let tup = BI.unsafeDataAsConstr d
ds0 = BI.snd tup
ds1 = BI.tail ds0
ds2 = BI.tail ds1
ds3 = BI.tail ds2
x = PlutusTx.unsafeFromBuiltinData (BI.head ds0)
y = PlutusTx.unsafeFromBuiltinData (BI.head ds1)
z = PlutusTx.unsafeFromBuiltinData (BI.head ds2)
w = PlutusTx.unsafeFromBuiltinData (BI.head ds3)
in (x, y, z, w)

packIntsManual :: Integer -> Integer -> Integer -> Integer -> PlutusTx.BuiltinData
packIntsManual x y z w =
BI.mkConstr
0
(BI.mkCons
(PlutusTx.toBuiltinData x)
(BI.mkCons
(PlutusTx.toBuiltinData y)
(BI.mkCons
(PlutusTx.toBuiltinData z)
(BI.mkCons
(PlutusTx.toBuiltinData w)
(BI.mkNilData BI.unitval)
)
)
)
)

int1Manual :: IntsManual -> Integer
int1Manual (IntsManual d) =
let tup = BI.unsafeDataAsConstr d
Expand Down

0 comments on commit b31eab9

Please # to comment.