Skip to content
Permalink
Browse files

use the Monoid instance for Data.Set

  • Loading branch information...
David Smith
David Smith committed Apr 14, 2019
1 parent 8662a4a commit 239731a06c0a37572149fcf76c50ec940eb3fb32
Showing with 34 additions and 35 deletions.
  1. +34 −35 meadow-client/src/Semantics.purs
@@ -3,8 +3,10 @@ module Semantics where
import Prelude
import Data.BigInteger (BigInteger, fromInt)
import Data.FoldableWithIndex (foldrWithIndexDefault)
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.Tuple (Tuple(..))
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))
@@ -1159,7 +1161,7 @@ class PeopleFrom a where

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)))
= S.fromFoldable (M.keys rpp) <> S.fromFoldable (map _.person (M.values ccbi))

instance peopleFromState :: PeopleFrom State where
peopleFrom (State { commits: comm }) = peopleFrom comm
@@ -1168,53 +1170,50 @@ 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 CurrentBlockF = mempty
algebra (CommittedF _) = mempty
algebra (ConstantF _) = mempty
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 (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.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 (BelowTimeoutF _) = mempty
algebra (AndObsF observation1 observation2) = observation1 <> observation2
algebra (OrObsF observation1 observation2) = 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
algebra (ChoseThisF v _) = S.insert (unwrap v).person mempty
algebra (ChoseSomethingF v) = S.insert (unwrap v).person mempty
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 = 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
algebra NullF = mempty
algebra (CommitF _ _ person value _ _ c1 c2) = S.insert person (peopleFrom value <> c1 <> c2)
algebra (PayF _ _ person value _ c1 c2) = S.insert 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 = peopleFrom sta
pcon = peopleFrom con
peopleFromStateAndContract sta con = S.toUnfoldable (peopleFrom sta <> peopleFrom con)

0 comments on commit 239731a

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