Add parameterised Case type

IntersectMBO · Oct 16, 2019 · 657adcd · 657adcd
1 parent c27bef9
commit 657adcd
Show file tree

Hide file tree

Showing 2 changed files with 23 additions and 20 deletions.
diff --git a/marlowe/src/Language/Marlowe3/Semantics.hs b/marlowe/src/Language/Marlowe3/Semantics.hs
@@ -186,7 +186,8 @@ data Payee = Account AccountId
 {-  Plutus doesn't support mutually recursive data types yet.
     datatype Case is mutually recurvive with @Contract@
 -}
-type Case = (Action, Contract)
+-- type Case = (Action, Contract)
+data Case a = Case Action a deriving (Show)
 
 
 {-| Marlowe has five ways of building contracts.
@@ -199,7 +200,7 @@ type Case = (Action, Contract)
 data Contract = Close
               | Pay AccountId Payee Value Contract
               | If Observation Contract Contract
-              | When [Case] Timeout Contract
+              | When [Case Contract] Timeout Contract
               | Let ValueId Value Contract
   deriving (Show)
 
@@ -551,9 +552,9 @@ reduceContractUntilQuiescent env state contract = let
 
 
 -- Apply a single Input to the contract (assumes the contract is reduced)
-applyCases :: Environment -> State -> Input -> [Case] -> ApplyResult
+applyCases :: Environment -> State -> Input -> [Case Contract] -> ApplyResult
 applyCases env state input cases = case (input, cases) of
-    (IDeposit accId1 party1 money, (Deposit accId2 party2 val, cont) : rest) -> let
+    (IDeposit accId1 party1 money, Case (Deposit accId2 party2 val) cont : rest) -> let
         amount = evalValue env state val
         warning = if amount > 0
             then ApplyNoWarning
@@ -562,12 +563,12 @@ applyCases env state input cases = case (input, cases) of
         in if accId1 == accId2 && party1 == party2 && Ada.getLovelace money == amount
         then Applied warning newState cont
         else applyCases env state input rest
-    (IChoice choId1 choice, (Choice choId2 bounds, cont) : rest) -> let
+    (IChoice choId1 choice, Case (Choice choId2 bounds) cont : rest) -> let
         newState = state { choices = Map.insert choId1 choice (choices state) }
         in if choId1 == choId2 && inBounds choice bounds
         then Applied ApplyNoWarning newState cont
         else applyCases env state input rest
-    (INotify, (Notify obs, cont) : _)
+    (INotify, Case (Notify obs) cont : _)
         | evalObservation env state obs -> Applied ApplyNoWarning state cont
     (_, _ : rest) -> applyCases env state input rest
     (_, []) -> ApplyNoMatchError
@@ -676,7 +677,7 @@ contractLifespanUpperBound contract = case contract of
     If _ contract1 contract2 ->
         max (contractLifespanUpperBound contract1) (contractLifespanUpperBound contract2)
     When cases timeout subContract -> let
-        contractsLifespans = fmap (\(_, cont) -> contractLifespanUpperBound cont) cases
+        contractsLifespans = fmap (\(Case _ cont) -> contractLifespanUpperBound cont) cases
         in maximum (getSlot timeout : contractLifespanUpperBound subContract : contractsLifespans)
     Let _ _ cont -> contractLifespanUpperBound cont
 
@@ -889,8 +890,9 @@ instance Eq Contract where
         obs1 == obs2 && cont1 == cont3 && cont2 == cont4
     When cases1 timeout1 cont1 == When cases2 timeout2 cont2 =
         timeout1 == timeout2 && cont1 == cont2
-        && let cases = (zip cases1 cases2)
-               checkCase ((action1, cont1), (action2, cont2)) = action1 == action2 && cont1 == cont2
+        && let cases = zip cases1 cases2
+               checkCase (Case action1 cont1, Case action2 cont2) =
+                    action1 == action2 && cont1 == cont2
            in all checkCase cases
     Let valId1 val1 cont1 == Let valId2 val2 cont2 =
         valId1 == valId2 && val1 == val2 && cont1 == cont2
@@ -918,6 +920,8 @@ makeLift ''Observation
 makeIsData ''Observation
 makeLift ''Action
 makeIsData ''Action
+makeLift ''Case
+makeIsData ''Case
 makeLift ''Payee
 makeIsData ''Payee
 makeLift ''Contract

diff --git a/marlowe/test/Spec/Marlowe3/Marlowe.hs b/marlowe/test/Spec/Marlowe3/Marlowe.hs
@@ -68,11 +68,11 @@ zeroCouponBondTest = checkMarloweTrace (MarloweScenario {
         update = updateAll [alice, bob]
     update
 
-    let zeroCouponBond = When [ (Deposit aliceAcc alicePk (Constant 850_000_000),
-            Pay aliceAcc (Party bobPk) (Constant 850_000_000)
+    let zeroCouponBond = When [ Case (Deposit aliceAcc alicePk (Constant 850_000_000))
+            (Pay aliceAcc (Party bobPk) (Constant 850_000_000)
                 (When
-                    [ (Deposit aliceAcc bobPk (Constant 1000_000_000),
-                        Pay aliceAcc (Party alicePk) (Constant 1000_000_000) Close)
+                    [ Case (Deposit aliceAcc bobPk (Constant 1000_000_000))
+                        (Pay aliceAcc (Party alicePk) (Constant 1000_000_000) Close)
                     ] (Slot 200) Close
                 ))] (Slot 100) Close
 
@@ -99,13 +99,12 @@ trustFundTest = checkMarloweTrace (MarloweScenario {
     let chId = ChoiceId 1 alicePk
 
     let contract = When [
-            (Choice chId [(100_000000, 1500_000000)],
-                When [
-                    (Deposit aliceAcc alicePk (ChoiceValue chId (Constant 0)),
-                        When [(Notify (SlotIntervalStart `ValueGE` Constant 150),
-                            Pay aliceAcc (Party bobPk) (ChoiceValue chId (Constant 0)) Close)]
-                        (Slot 300) Close
-                    )
+            Case (Choice chId [(100_000000, 1500_000000)])
+                (When [
+                    Case (Deposit aliceAcc alicePk (ChoiceValue chId (Constant 0)))
+                        (When [Case (Notify (SlotIntervalStart `ValueGE` Constant 150))
+                            (Pay aliceAcc (Party bobPk) (ChoiceValue chId (Constant 0)) Close)]
+                        (Slot 300) Close)
                     ] (Slot 200) Close)
             ] (Slot 100) Close