start to use cata for purescript marlowe semantics

meadow-client/bower.json

@@ -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": {

meadow-client/src/Marlowe/Types.purs

@@ -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

meadow-client/src/Semantics.purs

@@ -1,19 +1,14 @@
 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.List (List(Nil, Cons), concat, foldl, foldr)
 import Data.Maybe (Maybe(..), fromMaybe)
 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 +1154,67 @@ 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.union (S.fromFoldable (M.keys rpp)) (S.fromFoldable (map (\x -> x.person) (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 = S.empty
+      algebra (CommittedF _) = S.empty
+      algebra (ConstantF _) = S.empty
+      algebra (NegValueF value) = value
+      algebra (AddValueF value1 value2) = S.union value1 value2
+      algebra (SubValueF value1 value2) = S.union value1 value2
+      algebra (MulValueF value1 value2) = S.union value1 value2
+      algebra (DivValueF value1 value2 value3) = S.unions [value1, value2, value3]
+      algebra (ModValueF value1 value2 value3) = S.unions [value1, value2, value3]
+      algebra (ValueFromChoiceF v value) = S.insert (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 _) = S.empty
+      algebra (AndObsF observation1 observation2) = S.union observation1 observation2
+      algebra (OrObsF observation1 observation2) = S.union observation1 observation2
+      algebra (NotObsF observation) = observation
+      algebra (ChoseThisF v _) = S.insert (unwrap v).person S.empty
+      algebra (ChoseSomethingF v) = S.insert (unwrap v).person S.empty
+      algebra (ValueGEF value1 value2) = S.union (peopleFrom value1) (peopleFrom value2)
+      algebra (ValueGTF value1 value2) = S.union (peopleFrom value1) (peopleFrom value2)
+      algebra (ValueLTF value1 value2) = S.union (peopleFrom value1) (peopleFrom value2)
+      algebra (ValueLEF value1 value2) = S.union (peopleFrom value1) (peopleFrom value2)
+      algebra (ValueEQF value1 value2) = S.union (peopleFrom value1) (peopleFrom value2)
+      algebra TrueObsF = S.empty
+      algebra FalseObsF = S.empty
+
+instance peopleFromContract :: PeopleFrom Contract where
+  peopleFrom = cata algebra
+    where
+      algebra :: Algebra ContractF (S.Set Person)
+      algebra NullF = S.empty
+      algebra (CommitF _ _ person value _ _ c1 c2) = S.insert person (S.unions [peopleFrom value, c1, c2])
+      algebra (PayF _ _ person value _  c1 c2) = S.insert person (S.unions [peopleFrom value, c1, c2])
+      algebra (BothF c1 c2) = S.union c1 c2
+      algebra (ChoiceF observation c1 c2) = S.unions [peopleFrom observation, c1, c2]
+      algebra (WhenF observation _ c1 c2) = S.unions [peopleFrom observation, c1, c2]
+      algebra (WhileF observation _ c1 c2) = S.unions [peopleFrom observation, c1, c2]
+      algebra (ScaleF v1 v2 v3 c) = S.unions $ map peopleFrom [v1, v2, v3] <> [c]
+      algebra (LetF _ c1 c2) = S.union c1 c2
+      algebra (UseF _) = S.empty
 
 peopleFromStateAndContract :: State -> Contract -> List Person
 peopleFromStateAndContract sta con = S.toUnfoldable (S.union psta pcon)
   where
-  psta = peopleFromState sta
-  pcon = peopleFromContract con
+  psta = peopleFrom sta
+  pcon = peopleFrom con