Implement connection between input and transaction composers

meadow-client/src/MainFrame.purs

@@ -31,10 +31,11 @@ import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Class (class MonadEff, liftEff)
 import Control.Monad.Reader.Class (class MonadAsk)
 import Data.Array as Array
-import Data.Array (catMaybes)
+import Data.Array (catMaybes, delete, snoc)
 import Data.BigInteger (BigInteger, fromInt)
 import Data.Either (Either(..))
 import Data.Foldable (foldrDefault)
+import Data.Function (flip)
 import Data.Lens (assign, modifying, over, preview, set, use)
 import Data.List (List(..))
 import Data.Map (Map)
@@ -96,6 +97,7 @@ import Semantics
   ( BlockNumber
   , Choice
   , Contract(..)
+  , WIdChoice(..)
   , IdChoice(..)
   , IdInput(..)
   , IdOracle
@@ -254,6 +256,10 @@ toEvent (ApplyTrasaction _) = Just $ defaultEvent "ApplyTransaction"
 
 toEvent (NextBlock _) = Just $ defaultEvent "NextBlock"
 
+toEvent (AddAnyInput _ _) = Nothing
+
+toEvent (RemoveAnyInput _ _) = Nothing
+
 toEvent (CompileMarlowe _) = Just $ defaultEvent "CompileMarlowe"
 
 saveBuffer ::
@@ -288,7 +294,7 @@ updateSignatures oldState =
 
 updateChoices :: State -> Set IdInput -> Map Person (Map BigInteger Choice)
                  -> Map Person (Map BigInteger Choice)
-updateChoices state inputs cmap =
+updateChoices (State state) inputs cmap =
   foldrDefault addChoice Map.empty inputs
   where
     addChoice (InputIdChoice (IdChoice {choice: idChoice, person})) a =
@@ -300,7 +306,9 @@ updateChoices state inputs cmap =
                     Just z -> case Map.lookup idChoice z of
                                 Nothing -> fromInt 0
                                 Just v -> v in
-      Map.insert person (Map.insert idChoice dval pmap) cmap
+      if Map.member (WIdChoice (IdChoice {choice: idChoice, person})) state.choices
+      then a 
+      else Map.insert person (Map.insert idChoice dval pmap) a
     addChoice _ a = a
 
 updateOracles :: BlockNumber -> State -> Set IdInput -> Map IdOracle OracleEntry -> Map IdOracle OracleEntry
@@ -385,8 +393,7 @@ evalF (HandleDropEvent event next) = do
 
 evalF (MarloweHandleEditorMessage (TextChanged text) next) = do
   liftEff $ saveMarloweBuffer text
-  currentState <- use _marloweState
-  assign (_marloweState) $ updateContractInState text currentState
+  modifying (_marloweState) (updateContractInState text)
   pure next
 
 evalF (MarloweHandleDragEvent event next) = do
@@ -455,6 +462,7 @@ evalF (ScrollTo { row, column } next) = do
 
 evalF (SetSignature { person, isChecked } next) = do
   modifying (_marloweState <<< _transaction <<< _signatures) (Map.insert person isChecked)
+  modifying (_marloweState) updateState
   pure next
 
 --evalF (UpdatePerson person next) = do
@@ -472,8 +480,21 @@ evalF (ApplyTrasaction next) = pure next
 evalF (NextBlock next) = do
   modifying (_marloweState <<< _blockNum) (\x ->
     x + ((fromInt 1) :: BigInteger))
-  currentState <- use _marloweState
-  assign (_marloweState) $ updateState currentState
+  modifying (_marloweState) updateState
+  pure next
+
+evalF (AddAnyInput {person, anyInput} next) = do
+  modifying (_marloweState <<< _transaction <<< _inputs) ((flip snoc) anyInput)
+  case person of
+    Just per -> modifying (_marloweState <<< _transaction <<< _signatures)
+                          (Map.insert per true)
+    Nothing -> pure unit
+  modifying (_marloweState) updateState
+  pure next
+
+evalF (RemoveAnyInput anyInput next) = do
+  modifying (_marloweState <<< _transaction <<< _inputs) (delete anyInput)
+  modifying (_marloweState) updateState
   pure next
 
 evalF (CompileMarlowe next) = do

meadow-client/src/Simulation.purs

@@ -79,6 +79,7 @@ import Prelude
   , bind
   , const
   , discard
+  , not
   , pure
   , show
   , unit
@@ -105,6 +106,8 @@ import Types
   , OracleEntry
   , Query
       ( SetSignature
+      , AddAnyInput
+      , RemoveAnyInput
       , CompileMarlowe
       , NextBlock
       , ApplyTrasaction
@@ -254,57 +257,61 @@ inputCommit :: forall p. Person -> IdAction -> IdCommit -> BigInteger -> Timeout
                 -> HTML p Query
 inputCommit person idAction idCommit val tim =
   flexRow_ [ button [ class_ $ ClassName "composer-add-button"
---                    , onClick <<< input_ <<< UpdatePerson $ promoteAction person idx
+                    , onClick $ input_ $ AddAnyInput { person: Just person
+                                                     , anyInput: Action idAction }
                     ] [ text "+"
                       ]
            , spanText "Action "
-           , spanText (show idAction)
+           , b_ [ spanText (show idAction) ]
            , spanText ": Commit "
-           , spanText (show val)
+           , b_ [ spanText (show val) ]
            , spanText " ADA with id "
-           , spanText (show idCommit)
+           , b_ [ spanText (show idCommit) ]
            , spanText " to expire by "
-           , spanText (show tim)
+           , b_ [ spanText (show tim) ]
            ]
 
 inputPay :: forall p. Person -> IdAction -> IdCommit -> BigInteger -> HTML p Query
 inputPay person idAction idCommit val =
   flexRow_ [ button [ class_ $ ClassName "composer-add-button"
---                    , onClick <<< input_ <<< UpdatePerson $ promoteAction person idx
+                    , onClick $ input_ $ AddAnyInput { person: Just person
+                                                     , anyInput: Action idAction }
                     ] [ text "+"
                       ]
            , spanText "Action "
-           , spanText (show idAction)
+           , b_ [ spanText (show idAction) ]
            , spanText ": Claim "
-           , spanText (show val)
+           , b_ [ spanText (show val) ]
            , spanText " ADA from commit "
-           , spanText (show idCommit)
+           , b_ [ spanText (show idCommit) ]
            ]
 
 inputChoice :: forall p. Person -> BigInteger -> BigInteger -> HTML p Query
 inputChoice person idChoice val =
   flexRow_ [ button [ class_ $ ClassName "composer-add-button"
---                    , onClick <<< input_ <<< UpdatePerson $ promoteAction person idx
+                    , onClick $ input_ $ AddAnyInput { person: Just person
+                                                     , anyInput: Input (IChoice (IdChoice {choice: idChoice, person}) val) }
                     ] [ text "+"
                       ]
            , spanText "Choice "
-           , spanText (show idChoice)
+           , b_ [ spanText (show idChoice) ]
            , spanText ": Choose value "
-           , spanText (show val)
+           , b_ [ spanText (show val) ]
            ]
 
 inputComposerOracle :: forall p. Tuple IdOracle OracleEntry -> HTML p Query
 inputComposerOracle (Tuple idOracle {blockNumber, value}) =
   flexRow_ [ button [ class_ $ ClassName "composer-add-button"
---                    , onClick <<< input_ <<< UpdatePerson $ promoteAction person idx
+                    , onClick $ input_ $ AddAnyInput { person: Nothing 
+                                                     , anyInput: Input (IOracle idOracle blockNumber value) }
                     ] [ text "+"
                       ]
            , spanText "Oracle " 
-           , spanText (show idOracle)
+           , b_ [ spanText (show idOracle) ]
            , spanText ": Provide "
-           , spanText (show value)
+           , b_ [ spanText (show value) ]
            , spanText " as the value for block "
-           , spanText (show blockNumber)
+           , b_ [ spanText (show blockNumber) ]
            ]
 
 flexRow_ ::
@@ -375,26 +382,27 @@ signatures people = [ h3_ [text "Signatures"]
                     ]
 
 signature :: forall p. Tuple Person Boolean -> HTML p Query
-signature (Tuple person isChecked) = span [ class_ $ ClassName "pr-2"
-                                          ] [ input [ type_ InputCheckbox
-                                                    , onChecked $ Just <<< HQ.action <<< const (SetSignature { person
-                                                                                                             , isChecked
-                                                                                                             })
-                                                    , checked isChecked
-                                                    ]
-                                            , span_ [ text $ " Person " <> show person
-                                                    ]
-                                            ]
+signature (Tuple person isChecked) =
+  span [ class_ $ ClassName "pr-2"
+       ] [ input [ type_ InputCheckbox
+                 , onChecked $ Just <<< HQ.action <<< (\v -> SetSignature { person
+                                                                          , isChecked: v
+                                                                          })
+                 , checked isChecked
+                 ]
+         , span_ [ text $ " Person " <> show person
+                 ]
+         ]
 
 transactionInputs :: forall p. MarloweState -> Array (HTML p Query)
-transactionInputs state = [ h3_ [ text "Action list"
+transactionInputs state = [ h3_ [ text "Input list"
                                 ]
                           ] <> map (inputRow) state.transaction.inputs
 
 inputRow :: forall p. AnyInput -> HTML p Query
-inputRow (Action idAction) =
+inputRow idInput@(Action idAction) =
   row_ [ col_ [ button [ class_ $ ClassName "composer-add-button"
---                     , onClick <<< input_ <<< UpdatePerson $ demoteAction person idx
+                       , onClick $ input_ $ RemoveAnyInput idInput 
                        ] [ text "-"
                          ]
               , text "Action with id "
@@ -403,9 +411,9 @@ inputRow (Action idAction) =
               ]
        ]
 
-inputRow (Input (IChoice (IdChoice {choice, person}) val)) =
+inputRow idInput@(Input (IChoice (IdChoice {choice, person}) val)) =
   row_ [ col_ [ button [ class_ $ ClassName "composer-add-button"
---                     , onClick <<< input_ <<< UpdatePerson $ demoteAction person idx
+                       , onClick $ input_ $ RemoveAnyInput idInput 
                        ] [ text "-"
                          ]
               , text "Participant "

meadow-client/src/Types.purs

@@ -12,6 +12,7 @@ import Data.Lens (Lens')
 import Data.Lens.Record (prop)
 import Data.List (List)
 import Data.Map (Map)
+import Data.Maybe (Maybe(..))
 import Data.Symbol (SProxy(..))
 import Gist (Gist)
 import Halogen.Component.ChildPath (ChildPath, cpL, cpR)
@@ -54,6 +55,8 @@ data Query a
   | SetSignature {person :: Person, isChecked :: Boolean} a
   | ApplyTrasaction a
   | NextBlock a
+  | AddAnyInput {person :: Maybe Person, anyInput :: AnyInput} a
+  | RemoveAnyInput AnyInput a
   | CompileMarlowe a
 
 ------------------------------------------------------------