Skip to content

Instantly share code, notes, and snippets.

@ekhall

ekhall/Main.hs

Created January 18, 2021 15:36
Show Gist options
  • Save ekhall/c598930b48676f09f599432f63f415c9 to your computer and use it in GitHub Desktop.
Save ekhall/c598930b48676f09f599432f63f415c9 to your computer and use it in GitHub Desktop.
Download ZIP
Haskel1-escrow
Raw
blockly.xml
<xml xmlns="https://developers.google.com/blockly/xml"><block type="BaseContractType" id="root_contract" deletable="false" x="10" y="50"><statement name="BaseContractType"><block type="WhenContractType" id="y!W4x5;|#kYuS~ZPA*V)"><field name="timeout">0</field><statement name="case"><block type="DepositActionType" id="}Ru~BD,pT-EDsLhX}%Qr"><value name="from_party"><block type="RolePartyType" id="cG9yhl,bNE:jSUA09O=$"><field name="role">Client</field></block></value><value name="value"><block type="ConstantValueType" id="ximMy:=YelA).DioyDAY"><field name="constant">50</field></block></value><value name="token"><block type="AdaTokenType" id="2ooyW/@FEyoG#U7/%9q]"/></value><value name="party"><block type="RolePartyType" id="G+D=G883]{``:GbU3H;="><field name="role">Client</field></block></value><statement name="contract"><block type="WhenContractType" id="K:39[mUJf7HXGa!zzJrP"><field name="timeout">7</field><statement name="case"><block type="ChoiceActionType" id=",k/kgDiKOR6TG#=o749|"><field name="choice_name">name</field><value name="party"><block type="RolePartyType" id="HX4#f`v?3hOG;/cvbAa#"><field name="role">Client</field></block></value><statement name="bounds"><block type="BoundsType" id="S(_[~)2nsD6Dxa/(F?ZP"><field name="from">1</field><field name="to">3</field></block></statement><statement name="contract"><block type="IfContractType" id="|r9%,1.bDc5/_P4/Cc01"><value name="observation"><block type="ValueEQObservationType" id="Wz|f@b9IAhi#c!Tr8kJZ"><value name="value1"><block type="ChoiceValueValueType" id="Mhd:b*:rMf/C,@}9Qr9%"><field name="choice_name">name</field><value name="party"><block type="RolePartyType" id="0`P${R?B,[6rytBp,N(i"><field name="role">Client</field></block></value></block></value><value name="value2"><block type="ConstantValueType" id="{o18+oO*ueD2df5b.Y.I"><field name="constant">1</field></block></value></block></value><statement name="contract1"><block type="PayContractType" id="HXig|FnP2E^mYo2PphhP"><value name="payee"><block type="PartyPayeeType" id="rNgl!{p@?uZkYYzu1t31"><value name="party"><block type="RolePartyType" id="h#UiQUY)ePJrG8+D5urW"><field name="role">Coach</field></block></value></block></value><value name="value"><block type="ConstantValueType" id=";4c/h#N6?tFMOn`~g1]`"><field name="constant">50</field></block></value><value name="token"><block type="AdaTokenType" id="RX,ZB=jiLtYpwsIWTqxQ"/></value><value name="party"><block type="RolePartyType" id="HG)QwajQ3H8egcK?-M`~"><field name="role">Client</field></block></value><statement name="contract"><block type="CloseContractType" id="c!Z]5BlfYPq8-,M[B-:e"/></statement></block></statement><statement name="contract2"><block type="IfContractType" id="8m*PAZ@zx+bWxln#t#~f"><value name="observation"><block type="ValueEQObservationType" id="l~2hzr{JRfqm;m376SVf"><value name="value1"><block type="ChoiceValueValueType" id="G^:@s~OHVLYhgdCq;w@?"><field name="choice_name">name</field><value name="party"><block type="RolePartyType" id=".@%KM9XdkW^yLBZ`|sKA"><field name="role">Client</field></block></value></block></value><value name="value2"><block type="ConstantValueType" id="fJ=@=CGwL]=beo0Xi7)J"><field name="constant">2</field></block></value></block></value><statement name="contract1"><block type="PayContractType" id="$ijPh0dL44!q0=~wI-)f"><value name="payee"><block type="PartyPayeeType" id="0=0%[*N0hFly0c-tR$|G"><value name="party"><block type="RolePartyType" id="M5y82LX3+b(C9iKMHhRm"><field name="role">Coach</field></block></value></block></value><value name="value"><block type="ConstantValueType" id="rzZ;Jq8pXhGHe7L!JwI_"><field name="constant">10</field></block></value><value name="token"><block type="AdaTokenType" id="3oTwRwlK!K$#k`2-ei=3"/></value><value name="party"><block type="RolePartyType" id="92xc.pb3eNBg|cH:HIDl"><field name="role">Client</field></block></value><statement name="contract"><block type="CloseContractType" id="p0DG[g6t}R6lIlL-3}yE"/></statement></block></statement><statement name="contract2"><block type="PayContractType" id="nPPf7:W]7)v;H3967Wy)"><value name="payee"><block type="PartyPayeeType" id="FE)L/Ks^U0^AWRw*n*[H"><value name="party"><block type="RolePartyType" id="^FOSjX(sG0Owd*5Te-Mw"><field name="role">Coach</field></block></value></block></value><value name="value"><block type="ConstantValueType" id="2;!S|{8%c7@a(.J@pa^j"><field name="constant">25</field></block></value><value name="token"><block type="AdaTokenType" id="tgn?fEB13[J-Fuh]LT;f"/></value><value name="party"><block type="RolePartyType" id="1G,S4aT9lfbCwl6b`gqH"><field name="role">Client</field></block></value><statement name="contract"><block type="CloseContractType" id="E`WQt$tG%4^AoRn_XRuZ"/></statement></block></statement></block></statement></block></statement></block></statement><statement name="contract"><block type="CloseContractType" id="_:$UZaqwFp(4`X`C,9?$"/></statement></block></statement></block></statement></block></statement></block></xml>
Raw
Main.hs
{-# LANGUAGE OverloadedStrings #-}
module Escrow where
import Language.Marlowe
main :: IO ()
main = print . pretty $ contract
{- What does the vanilla contract look like?
- if Alice and Bob choose
- and agree: do it
- and disagree: Carol decides
- Carol also decides if timeout after one choice has been made;
- refund if no choices are made.
-}
contract :: Contract
contract = When [Case (Deposit "alice" "alice" ada price) inner]
10
Close
inner :: Contract
inner =
When [ Case aliceChoice
(When [ Case bobChoice
(If (aliceChosen `ValueEQ` bobChosen)
agreement
arbitrate) ]
60
arbitrate)
]
40
arbitrate
-- The contract to follow when Alice and Bob have made the same choice.
agreement :: Contract
agreement =
If
(aliceChosen `ValueEQ` Constant 0)
(Pay "alice" (Party "bob") ada price Close)
Close
-- The contract to follow when Alice and Bob disagree, or if
-- Carol has to intervene after a single choice from Alice or Bob.
arbitrate :: Contract
arbitrate =
When [ Case carolRefund Close,
Case carolPay (Pay "alice" (Party "bob") ada price Close) ]
100
Close
-- Names for choices
pay,refund,both :: [Bound]
pay = [Bound 0 0]
refund = [Bound 1 1]
both = [Bound 0 1]
-- helper function to build Actions
choiceName :: ChoiceName
choiceName = "choice"
choice :: Party -> [Bound] -> Action
choice party = Choice (ChoiceId choiceName party)
-- Name choices according to person making choice and choice made
alicePay, aliceRefund, aliceChoice, bobPay, bobRefund, bobChoice, carolPay, carolRefund, carolChoice :: Action
alicePay = choice "alice" pay
aliceRefund = choice "alice" refund
aliceChoice = choice "alice" both
bobPay = choice "bob" pay
bobRefund = choice "bob" refund
bobChoice = choice "bob" both
carolPay = choice "carol" pay
carolRefund = choice "carol" refund
carolChoice = choice "carol" both
-- the values chosen in choices
aliceChosen, bobChosen :: (Value Observation)
aliceChosen = ChoiceValue (ChoiceId choiceName "alice")
bobChosen = ChoiceValue (ChoiceId choiceName "bob")
defValue :: (Value Observation)
defValue = Constant 42
-- Value under escrow
price :: (Value Observation)
price = Constant 450
Raw
playground.marlowe
When
[Case
(Deposit
(Role "alice")
(Role "alice")
(Token "" "")
(Constant 450)
)
(When
[Case
(Choice
(ChoiceId
"choice"
(Role "alice")
)
[Bound 0 1]
)
(When
[Case
(Choice
(ChoiceId
"choice"
(Role "bob")
)
[Bound 0 1]
)
(If
(ValueEQ
(ChoiceValue
(ChoiceId
"choice"
(Role "alice")
))
(ChoiceValue
(ChoiceId
"choice"
(Role "bob")
))
)
(If
(ValueEQ
(ChoiceValue
(ChoiceId
"choice"
(Role "alice")
))
(Constant 0)
)
(Pay
(Role "alice")
(Party (Role "bob"))
(Token "" "")
(Constant 450)
Close
)
Close
)
(When
[Case
(Choice
(ChoiceId
"choice"
(Role "carol")
)
[Bound 1 1]
)
Close , Case
(Choice
(ChoiceId
"choice"
(Role "carol")
)
[Bound 0 0]
)
(Pay
(Role "alice")
(Party (Role "bob"))
(Token "" "")
(Constant 450)
Close
)]
100 Close
)
)]
60
(When
[Case
(Choice
(ChoiceId
"choice"
(Role "carol")
)
[Bound 1 1]
)
Close , Case
(Choice
(ChoiceId
"choice"
(Role "carol")
)
[Bound 0 0]
)
(Pay
(Role "alice")
(Party (Role "bob"))
(Token "" "")
(Constant 450)
Close
)]
100 Close
)
)]
40
(When
[Case
(Choice
(ChoiceId
"choice"
(Role "carol")
)
[Bound 1 1]
)
Close , Case
(Choice
(ChoiceId
"choice"
(Role "carol")
)
[Bound 0 0]
)
(Pay
(Role "alice")
(Party (Role "bob"))
(Token "" "")
(Constant 450)
Close
)]
100 Close
)
)]
10 Close
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment