Skip to content
Permalink
Browse files

Merge pull request #910 from input-output-hk/meadow-cata

start to use cata for purescript marlowe semantics
  • Loading branch information...
shmish111 committed Apr 15, 2019
2 parents 40a9675 + e9cd898 commit 44f77611abab3924650193eff77063e3c81aca61
Showing with 198 additions and 89 deletions.
  1. +2 −0 meadow-client/bower-packages.nix
  2. +1 −0 meadow-client/bower.json
  3. +134 −1 meadow-client/src/Marlowe/Types.purs
  4. +61 −88 meadow-client/src/Semantics.purs
@@ -18,6 +18,7 @@ buildEnv { name = "bower-env"; ignoreCollisions = true; paths = [
(fetchbower "purescript-undefinable" "3.0.0" "3.0.0" "054syian34wmsxnrjm5wpqycqw82mhvq2fgpwk9kjqqipvghlck4")
(fetchbower "purescript-aff" "4.1.1" "4.1.1" "14xv4g1wqygr2j6c07dqrxy2j0gy111cbw2awx0fd4lvp9gsqg4n")
(fetchbower "purescript-bigints" "3.5.0" "^3.5.0" "14911p3qgln0jxam3jxdc50z4d41lvrnv3dmcqc9wr7bsyfvmxxw")
(fetchbower "purescript-matryoshka" "0.3.0" "0.3.0" "0n9c9xmgcz2609m8md3cz3k4lrkp350rz8474akpw86avc0rmja2")
(fetchbower "purescript-simple-parser" "7.0.0" "^7.0.0" "132clrl3zbf8vjb21yf821l8y2nnn6bdmjjiq224293dwyp6faim")
(fetchbower "purescript-psci-support" "3.0.0" "3.0.0" "1453gzzgbxny9bx3sz6fhfbc4hw0hnhk30633w3hcvdwsw432bi3")
(fetchbower "purescript-test-unit" "13.0.0" "13.0.0" "108vvviamsrhxdp9gry5ybd828g8yrq23azjkph34yd57579n3cg")
@@ -68,6 +69,7 @@ buildEnv { name = "bower-env"; ignoreCollisions = true; paths = [
(fetchbower "purescript-type-equality" "2.1.0" "^2.1.0" "17mxy6yw3awvf1lz72qkrgvxpxg0rl4bhhd6icak4k7dswy1pxl4")
(fetchbower "purescript-avar" "2.0.1" "^2.0.0" "1sjxp4bd3vs6kxqr2a97h3ahicwky87f9n0j6b78ilrr5cb8md9x")
(fetchbower "purescript-strings" "3.5.0" "^3.5.0" "0b478dmwdsdpaxxh7yazjvmd3qh21bkn1f2z8mzwqpmc844lba8l")
(fetchbower "purescript-fixed-points" "4.0.0" "^4.0.0" "0xyqii5c3kg50kznd6hbycyzcvyf1wsrssp3zbwig89lvnwc2y52")
(fetchbower "purescript-control" "3.3.1" "^3.3.0" "1hvz8b04msk2a30586b460ayj8f706rafwhvg201hjgm7fr319km")
(fetchbower "purescript-lists" "4.12.0" "^4.9.0" "0rj92pk1v3nqm1yfvzzhw6lib4zgj4cc1iiswzl8isji66k7nr67")
(fetchbower "purescript-quickcheck" "4.7.0" "^4.0.0" "1qcl20xy6ypk219vayf8i0c970fsnrq40bcxl15sd9cp22zyij0a")
@@ -33,6 +33,7 @@
"purescript-undefinable": "3.0.0",
"purescript-aff": "4.1.1",
"purescript-bigints": "^3.5.0",
"purescript-matryoshka": "0.3.0",
"purescript-simple-parser": "^7.0.0"
},
"devDependencies": {
@@ -9,6 +9,8 @@ import Data.Newtype (class Newtype)
import Data.String (joinWith)
import Marlowe.Pretty (class Pretty, genericPretty)
import Text.PrettyPrint.Leijen (text)
import Matryoshka.Class.Recursive (class Recursive)
import Matryoshka.Class.Corecursive (class Corecursive)

type BlockNumber
= BigInteger
@@ -63,6 +65,7 @@ type IdOracle
type LetLabel
= BigInteger

---------------------------- Value ----------------------------
data Value
= CurrentBlock
| Committed IdCommit
@@ -88,6 +91,48 @@ instance showValue :: Show Value where
instance prettyValue :: Pretty Value where
prettyFragment a = genericPretty a

data ValueF f
= CurrentBlockF
| CommittedF IdCommit
| ConstantF BigInteger
| NegValueF f
| AddValueF f f
| SubValueF f f
| MulValueF f f
| DivValueF f f f
| ModValueF f f f
| ValueFromChoiceF IdChoice f
| ValueFromOracleF IdOracle f

derive instance functorValueF :: Functor ValueF
derive instance eqValueF :: Eq f => Eq (ValueF f)

instance recursiveValue :: Recursive Value ValueF where
project CurrentBlock = CurrentBlockF
project (Committed i) = CommittedF i
project (Constant i) = ConstantF i
project (NegValue v) = NegValueF v
project (AddValue v1 v2) = AddValueF v1 v2
project (SubValue v1 v2) = SubValueF v1 v2
project (MulValue v1 v2) = MulValueF v1 v2
project (DivValue v1 v2 v3) = DivValueF v1 v2 v3
project (ModValue v1 v2 v3) = ModValueF v1 v2 v3
project (ValueFromChoice i v) = ValueFromChoiceF i v
project (ValueFromOracle i v) = ValueFromOracleF i v

instance corecursiveValue :: Corecursive Value ValueF where
embed CurrentBlockF = CurrentBlock
embed (CommittedF i) = Committed i
embed (ConstantF i) = Constant i
embed (NegValueF v) = NegValue v
embed (AddValueF v1 v2) = AddValue v1 v2
embed (SubValueF v1 v2) = SubValue v1 v2
embed (MulValueF v1 v2) = MulValue v1 v2
embed (DivValueF v1 v2 v3) = DivValue v1 v2 v3
embed (ModValueF v1 v2 v3) = ModValue v1 v2 v3
embed (ValueFromChoiceF i v) = ValueFromChoice i v
embed (ValueFromOracleF i v) = ValueFromOracle i v
---------------------------- Observation ----------------------------
data Observation
= BelowTimeout Timeout
| AndObs Observation Observation
@@ -115,6 +160,55 @@ instance showObservation :: Show Observation where
instance prettyObservation :: Pretty Observation where
prettyFragment a = genericPretty a

data ObservationF f
= BelowTimeoutF Timeout
| AndObsF f f
| OrObsF f f
| NotObsF f
| ChoseThisF IdChoice Choice
| ChoseSomethingF IdChoice
| ValueGEF Value Value
| ValueGTF Value Value
| ValueLTF Value Value
| ValueLEF Value Value
| ValueEQF Value Value
| TrueObsF
| FalseObsF

derive instance functorObservationF :: Functor ObservationF
derive instance eqObservationF :: Eq f => Eq (ObservationF f)

instance recursiveObservation :: Recursive Observation ObservationF where
project (BelowTimeout t) = BelowTimeoutF t
project (AndObs o1 o2) = AndObsF o1 o2
project (OrObs o1 o2) = OrObsF o1 o2
project (NotObs o) = NotObsF o
project (ChoseThis i c) = ChoseThisF i c
project (ChoseSomething i) = ChoseSomethingF i
project (ValueGE v1 v2) = ValueGEF v1 v2
project (ValueGT v1 v2) = ValueGTF v1 v2
project (ValueLT v1 v2) = ValueLTF v1 v2
project (ValueLE v1 v2) = ValueLEF v1 v2
project (ValueEQ v1 v2) = ValueEQF v1 v2
project TrueObs = TrueObsF
project FalseObs = FalseObsF

instance corecursiveObservation :: Corecursive Observation ObservationF where
embed (BelowTimeoutF t) = BelowTimeout t
embed (AndObsF o1 o2) = AndObs o1 o2
embed (OrObsF o1 o2) = OrObs o1 o2
embed (NotObsF o) = NotObs o
embed (ChoseThisF i c) = ChoseThis i c
embed (ChoseSomethingF i) = ChoseSomething i
embed (ValueGEF v1 v2) = ValueGE v1 v2
embed (ValueGTF v1 v2) = ValueGT v1 v2
embed (ValueLTF v1 v2) = ValueLT v1 v2
embed (ValueLEF v1 v2) = ValueLE v1 v2
embed (ValueEQF v1 v2) = ValueEQ v1 v2
embed TrueObsF = TrueObs
embed FalseObsF = FalseObs

---------------------------- Contract ----------------------------
data Contract
= Null
| Commit IdAction IdCommit Person Value Timeout Timeout Contract Contract
@@ -137,4 +231,43 @@ instance showContract :: Show Contract where
show c = genericShow c

instance prettyContract :: Pretty Contract where
prettyFragment a = genericPretty a
prettyFragment a = genericPretty a

data ContractF f
= NullF
| CommitF IdAction IdCommit Person Value Timeout Timeout f f
| PayF IdAction IdCommit Person Value Timeout f f
| BothF f f
| ChoiceF Observation f f
| WhenF Observation Timeout f f
| WhileF Observation Timeout f f
| ScaleF Value Value Value f
| LetF LetLabel f f
| UseF LetLabel

derive instance functorContractF :: Functor ContractF
derive instance eqContractF :: Eq f => Eq (ContractF f)

instance recursiveContract :: Recursive Contract ContractF where
project Null = NullF
project (Commit ia ic p v t1 t2 c1 c2) = CommitF ia ic p v t1 t2 c1 c2
project (Pay ia ic p v t c1 c2) = PayF ia ic p v t c1 c2
project (Both c1 c2) = BothF c1 c2
project (Choice o c1 c2) = ChoiceF o c1 c2
project (When o t c1 c2) = WhenF o t c1 c2
project (While o t c1 c2) = WhileF o t c1 c2
project (Scale v1 v2 v3 c) = ScaleF v1 v2 v3 c
project (Let l c1 c2) = LetF l c1 c2
project (Use l) = UseF l

instance corecursiveContract :: Corecursive Contract ContractF where
embed NullF = Null
embed (CommitF ia ic p v t1 t2 c1 c2) = Commit ia ic p v t1 t2 c1 c2
embed (PayF ia ic p v t c1 c2) = Pay ia ic p v t c1 c2
embed (BothF c1 c2) = Both c1 c2
embed (ChoiceF o c1 c2) = Choice o c1 c2
embed (WhenF o t c1 c2) = When o t c1 c2
embed (WhileF o t c1 c2) = While o t c1 c2
embed (ScaleF v1 v2 v3 c) = Scale v1 v2 v3 c
embed (LetF l c1 c2) = Let l c1 c2
embed (UseF l) = Use l
@@ -1,19 +1,16 @@
module Semantics where

import Control.Monad

import Prelude
import Data.BigInteger (BigInteger, fromInt)
import Data.Eq (class Eq, (/=), (==))
import Data.EuclideanRing (div, mod)
import Data.FoldableWithIndex (foldrWithIndexDefault)
import Data.HeytingAlgebra (not, (&&), (||))
import Data.Foldable (foldMap)
import Data.List (List(Nil, Cons), concat, foldl, foldr)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Monoid (mempty)
import Data.Newtype (unwrap)
import Data.Ord (class Ord, max, (<), (<=), (>), (>=))
import Data.Ring (negate, (*), (+), (-))
import Data.Tuple (Tuple(..))
import Marlowe.Types (BlockNumber, Choice, Contract(Use, Let, Scale, While, When, Choice, Both, Pay, Commit, Null), IdAction, IdChoice, IdCommit, IdOracle, LetLabel, Observation(FalseObs, TrueObs, ValueEQ, ValueLE, ValueLT, ValueGT, ValueGE, ChoseSomething, ChoseThis, NotObs, OrObs, AndObs, BelowTimeout), Person, Timeout, Value(ValueFromOracle, ValueFromChoice, ModValue, DivValue, MulValue, SubValue, AddValue, NegValue, Constant, Committed, CurrentBlock), WIdChoice(WIdChoice))
import Marlowe.Types (BlockNumber, Choice, ValueF(..), ObservationF(..), ContractF(..), Contract(Use, Let, Scale, While, When, Choice, Both, Pay, Commit, Null), IdAction, IdChoice, IdCommit, IdOracle, LetLabel, Observation(FalseObs, TrueObs, ValueEQ, ValueLE, ValueLT, ValueGT, ValueGE, ChoseSomething, ChoseThis, NotObs, OrObs, AndObs, BelowTimeout), Person, Timeout, Value(ValueFromOracle, ValueFromChoice, ModValue, DivValue, MulValue, SubValue, AddValue, NegValue, Constant, Committed, CurrentBlock), WIdChoice(WIdChoice))
import Matryoshka (Algebra, cata)

import Data.Foldable as F
import Data.Map as M
@@ -1159,88 +1156,64 @@ applyTransaction inputs sigs blockNum state contract value = case appResult of
appResult = applyAnyInputs inputs sigs neededInputs blockNum expiredState reducedContract value emptyOutcome Nil

-- Extract participants from state and contract
peopleFromCommitInfo ::
CommitInfo ->
S.Set Person
peopleFromCommitInfo (CommitInfo { redeemedPerPerson: rpp, currentCommitsById: ccbi }) = S.union (S.fromFoldable (M.keys rpp)) (S.fromFoldable (map (\x ->
x.person) (M.values ccbi)))

peopleFromState :: State -> S.Set Person
peopleFromState (State { commits: comm }) = peopleFromCommitInfo comm

peopleFromValue :: Value -> S.Set Person
peopleFromValue CurrentBlock = S.empty

peopleFromValue (Committed _) = S.empty

peopleFromValue (Constant _) = S.empty

peopleFromValue (NegValue value) = peopleFromValue value

peopleFromValue (AddValue value1 value2) = S.union (peopleFromValue value1) (peopleFromValue value2)

peopleFromValue (SubValue value1 value2) = S.union (peopleFromValue value1) (peopleFromValue value2)

peopleFromValue (MulValue value1 value2) = S.union (peopleFromValue value1) (peopleFromValue value2)

peopleFromValue (DivValue value1 value2 value3) = S.union (peopleFromValue value1) (S.union (peopleFromValue value2) (peopleFromValue value3))

peopleFromValue (ModValue value1 value2 value3) = S.union (peopleFromValue value1) (S.union (peopleFromValue value2) (peopleFromValue value3))

peopleFromValue (ValueFromChoice v value) = S.insert (unwrap v).person (peopleFromValue value)

peopleFromValue (ValueFromOracle _ value) = peopleFromValue value

peopleFromObservation :: Observation -> S.Set Person
peopleFromObservation (BelowTimeout _) = S.empty

peopleFromObservation (AndObs observation1 observation2) = S.union (peopleFromObservation observation1) (peopleFromObservation observation2)

peopleFromObservation (OrObs observation1 observation2) = S.union (peopleFromObservation observation1) (peopleFromObservation observation2)

peopleFromObservation (NotObs observation) = peopleFromObservation observation

peopleFromObservation (ChoseThis v _) = S.insert (unwrap v).person S.empty
class PeopleFrom a where
peopleFrom :: a -> S.Set Person

peopleFromObservation (ChoseSomething v) = S.insert (unwrap v).person S.empty
instance peopleFromCommitInfo :: PeopleFrom CommitInfo where
peopleFrom (CommitInfo { redeemedPerPerson: rpp, currentCommitsById: ccbi })
= S.fromFoldable (M.keys rpp) <> foldMap (_.person >>> S.singleton) (M.values ccbi)

peopleFromObservation (ValueGE value1 value2) = S.union (peopleFromValue value1) (peopleFromValue value2)
instance peopleFromState :: PeopleFrom State where
peopleFrom (State { commits: comm }) = peopleFrom comm

peopleFromObservation (ValueGT value1 value2) = S.union (peopleFromValue value1) (peopleFromValue value2)

peopleFromObservation (ValueLT value1 value2) = S.union (peopleFromValue value1) (peopleFromValue value2)

peopleFromObservation (ValueLE value1 value2) = S.union (peopleFromValue value1) (peopleFromValue value2)

peopleFromObservation (ValueEQ value1 value2) = S.union (peopleFromValue value1) (peopleFromValue value2)

peopleFromObservation TrueObs = S.empty

peopleFromObservation FalseObs = S.empty

peopleFromContract :: Contract -> S.Set Person
peopleFromContract Null = S.empty

peopleFromContract (Commit _ _ person value _ _ contract1 contract2) = S.insert person (S.union (peopleFromValue value) (S.union (peopleFromContract contract1) (peopleFromContract contract2)))

peopleFromContract (Pay _ _ person value _ contract1 contract2) = S.insert person (S.union (peopleFromValue value) (S.union (peopleFromContract contract1) (peopleFromContract contract2)))

peopleFromContract (Both contract1 contract2) = S.union (peopleFromContract contract1) (peopleFromContract contract2)

peopleFromContract (Choice observation contract1 contract2) = S.union (peopleFromObservation observation) (S.union (peopleFromContract contract1) (peopleFromContract contract2))

peopleFromContract (When observation timeout contract1 contract2) = S.union (peopleFromObservation observation) (S.union (peopleFromContract contract1) (peopleFromContract contract2))

peopleFromContract (While observation timeout contract1 contract2) = S.union (peopleFromObservation observation) (S.union (peopleFromContract contract1) (peopleFromContract contract2))

peopleFromContract (Scale value1 value2 value3 contract) = S.union (peopleFromValue value1) (S.union (peopleFromValue value2) (S.union (peopleFromValue value3) (peopleFromContract contract)))

peopleFromContract (Let _ contract1 contract2) = S.union (peopleFromContract contract1) (peopleFromContract contract2)

peopleFromContract (Use _) = S.empty
instance peopleFromValue :: PeopleFrom Value where
peopleFrom = cata algebra
where
algebra :: Algebra ValueF (S.Set Person)
algebra CurrentBlockF = mempty
algebra (CommittedF _) = mempty
algebra (ConstantF _) = mempty
algebra (NegValueF value) = value
algebra (AddValueF value1 value2) = value1 <> value2
algebra (SubValueF value1 value2) = value1 <> value2
algebra (MulValueF value1 value2) = value1 <> value2
algebra (DivValueF value1 value2 value3) = value1 <> value2 <> value3
algebra (ModValueF value1 value2 value3) = value1 <> value2 <> value3
algebra (ValueFromChoiceF v value) = S.singleton (unwrap v).person <> value
algebra (ValueFromOracleF _ value) = value

instance peopleFromObservation :: PeopleFrom Observation where
peopleFrom = cata algebra
where
algebra :: Algebra ObservationF (S.Set Person)
algebra (BelowTimeoutF _) = mempty
algebra (AndObsF observation1 observation2) = observation1 <> observation2
algebra (OrObsF observation1 observation2) = observation1 <> observation2
algebra (NotObsF observation) = observation
algebra (ChoseThisF v _) = S.singleton (unwrap v).person
algebra (ChoseSomethingF v) = S.singleton (unwrap v).person
algebra (ValueGEF value1 value2) = peopleFrom value1 <> peopleFrom value2
algebra (ValueGTF value1 value2) = peopleFrom value1 <> peopleFrom value2
algebra (ValueLTF value1 value2) = peopleFrom value1 <> peopleFrom value2
algebra (ValueLEF value1 value2) = peopleFrom value1 <> peopleFrom value2
algebra (ValueEQF value1 value2) = peopleFrom value1 <> peopleFrom value2
algebra TrueObsF = mempty
algebra FalseObsF = mempty

instance peopleFromContract :: PeopleFrom Contract where
peopleFrom = cata algebra
where
algebra :: Algebra ContractF (S.Set Person)
algebra NullF = mempty
algebra (CommitF _ _ person value _ _ c1 c2) = S.singleton person <> peopleFrom value <> c1 <> c2
algebra (PayF _ _ person value _ c1 c2) = S.singleton person <> peopleFrom value <> c1 <> c2
algebra (BothF c1 c2) = c1 <> c2
algebra (ChoiceF observation c1 c2) = peopleFrom observation <> c1 <> c2
algebra (WhenF observation _ c1 c2) = peopleFrom observation <> c1 <> c2
algebra (WhileF observation _ c1 c2) = peopleFrom observation <> c1 <> c2
algebra (ScaleF v1 v2 v3 c) = foldMap peopleFrom [v1, v2, v3] <> c
algebra (LetF _ c1 c2) = c1 <> c2
algebra (UseF _) = mempty

peopleFromStateAndContract :: State -> Contract -> List Person
peopleFromStateAndContract sta con = S.toUnfoldable (S.union psta pcon)
where
psta = peopleFromState sta
pcon = peopleFromContract con
peopleFromStateAndContract sta con = S.toUnfoldable (peopleFrom sta <> peopleFrom con)

0 comments on commit 44f7761

Please sign in to comment.
You can’t perform that action at this time.