Skip to content
Permalink
Browse files

Implement connection between input and transaction composers

  • Loading branch information...
palas committed Mar 14, 2019
1 parent afd9c68 commit ddc5566fce43b7ba30236ca4d0d7ed94c996fbeb
Showing with 70 additions and 38 deletions.
  1. +28 −7 meadow-client/src/MainFrame.purs
  2. +39 −31 meadow-client/src/Simulation.purs
  3. +3 −0 meadow-client/src/Types.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
@@ -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 "
@@ -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

------------------------------------------------------------

0 comments on commit ddc5566

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