diff --git a/meadow-client/src/MainFrame.purs b/meadow-client/src/MainFrame.purs index 41235b9de99..9a4267634fe 100644 --- a/meadow-client/src/MainFrame.purs +++ b/meadow-client/src/MainFrame.purs @@ -99,6 +99,7 @@ import Semantics , IdChoice(..) , IdInput(..) , IdOracle + , ErrorResult(..) , MApplicationResult(..) , Person , State(..) @@ -107,6 +108,7 @@ import Semantics , emptyState , peopleFromStateAndContract , readContract + , reduce , scoutPrimitives ) import Servant.PureScript.Settings (SPSettings_) @@ -334,6 +336,10 @@ simulateState state = case applyTransaction inps sigs bn st c mic of MSuccessfullyApplied {state: newState, contract: newContract} _ -> {state: newState, contract: newContract} + MCouldNotApply InvalidInput -> + if inps == Nil + then {state: st, contract: reduce state.blockNum state.state c} + else {state: emptyState, contract: Null} MCouldNotApply _ -> {state: emptyState, contract: Null} where inps = Array.toUnfoldable (state.transaction.inputs) @@ -466,6 +472,8 @@ evalF (ApplyTrasaction next) = pure next evalF (NextBlock next) = do modifying (_marloweState <<< _blockNum) (\x -> x + ((fromInt 1) :: BigInteger)) + currentState <- use _marloweState + assign (_marloweState) $ updateState currentState pure next evalF (CompileMarlowe next) = do diff --git a/meadow-client/src/Semantics.purs b/meadow-client/src/Semantics.purs index bc5433a6556..6eb45ceef6a 100644 --- a/meadow-client/src/Semantics.purs +++ b/meadow-client/src/Semantics.purs @@ -1001,7 +1001,7 @@ reduceRec blockNum state env (Choice obs cont1 cont2) = reduceRec blockNum state then cont1 else cont2) -reduceRec blockNum state env c@(When obs timeout cont1 cont2) = if isExpired timeout blockNum +reduceRec blockNum state env c@(When obs timeout cont1 cont2) = if isExpired blockNum timeout then go cont2 else if evalObservation blockNum state obs then go cont1 @@ -1218,8 +1218,8 @@ fetchPrimitive idAction blockNum state (Commit idActionC idCommit person value _ } else NoMatch where - notCurrentCommit = isCurrentCommit idCommit state - notExpiredCommit = isExpiredCommit idCommit state + notCurrentCommit = not (isCurrentCommit idCommit state) + notExpiredCommit = not (isExpiredCommit idCommit state) actualValue = evalValue blockNum state value fetchPrimitive idAction blockNum state (Pay idActionC idCommit person value _ continuation _) = if (idAction == idActionC) @@ -1276,8 +1276,8 @@ scoutPrimitivesAux blockNum state (Commit idActionC idCommit person value _ time then M.insert idActionC (Just (DCommit idCommit person actualValue timeout)) M.empty else M.empty where - notCurrentCommit = isCurrentCommit idCommit state - notExpiredCommit = isExpiredCommit idCommit state + notCurrentCommit = not (isCurrentCommit idCommit state) + notExpiredCommit = not (isExpiredCommit idCommit state) actualValue = evalValue blockNum state value scoutPrimitivesAux blockNum state (Pay idActionC idCommit person value _ continuation _) = diff --git a/meadow-client/src/Simulation.purs b/meadow-client/src/Simulation.purs index 6bd50dfd25e..73a50e0430b 100644 --- a/meadow-client/src/Simulation.purs +++ b/meadow-client/src/Simulation.purs @@ -3,7 +3,7 @@ module Simulation where import Data.BigInteger (BigInteger) import Semantics import Data.Map (Map) -import Data.List (List) +import Data.List (List(..), concatMap) import Data.Set (Set) import Data.Set as Set import API (RunResult(RunResult)) @@ -28,7 +28,7 @@ import Control.Monad.Eff (Eff) import Control.Monad.Eff.Class (liftEff) import Data.Either (Either(..)) import Data.Eq ((==)) -import Data.Maybe (Maybe(Just), fromMaybe) +import Data.Maybe (Maybe(..), fromMaybe) import Data.Tuple (Tuple(..)) import Halogen (HTML, action) import Halogen.Component (ParentHTML) @@ -92,12 +92,14 @@ import Types ( ChildQuery , ChildSlot , FrontendState + , InputData , MarloweEditorSlot ( MarloweEditorSlot ) , MarloweError ( MarloweError ) + , OracleEntry , Query ( SetSignature , CompileMarlowe @@ -204,13 +206,105 @@ inputComposerPane state = div [ classes [ col6 ] ] [ paneHeader "Input Composer" , div [ class_ $ ClassName "wallet" - ] [ card_ [ cardBody_ [ h3_ [ text ("Person " <> "3") - ] - ] + ] [ card_ [ cardBody_ (inputComposer (state.marloweState.input)) ] ] ] +inputComposer :: forall p. InputData -> Array (HTML p Query) +inputComposer { inputs, choiceData, oracleData } = + Array.concat [ Array.concat (Array.fromFoldable (map (\x -> inputComposerPerson x inputs choiceData) people)) + , if (Map.isEmpty oracleData) + then [] + else [ h3_ [ text ("Oracles") ] ] + , Array.fromFoldable (map inputComposerOracle oracles) + ] + where + ik = Set.fromFoldable (Map.keys inputs) + cdk = Set.fromFoldable (Map.keys choiceData) + people = Set.toUnfoldable (Set.union ik cdk) :: List Person + oracles = Map.toUnfoldable oracleData :: List (Tuple IdOracle OracleEntry) + +inputComposerPerson :: forall p. Person -> Map Person (List DetachedPrimitiveWIA) + -> Map Person (Map BigInteger Choice) + -> Array (HTML p Query) +inputComposerPerson person inputs choices = + Array.concat + [ [ h3_ [ text ("Person " <> show person) + ] ] + , case Map.lookup person inputs of + Nothing -> [] + Just x -> Array.fromFoldable + do y <- x + case y of + DWAICommit idAction idCommit val tim -> + pure (inputCommit person idAction idCommit val tim) + DWAIPay idAction idCommit val -> + pure (inputPay person idAction idCommit val) + , case Map.lookup person choices of + Nothing -> [] + Just x -> do (Tuple idChoice choice) <- Map.toUnfoldable x + pure (inputChoice person idChoice choice) + ] + +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 + ] [ text "+" + ] + , spanText "Action " + , spanText (show idAction) + , spanText ": Commit " + , spanText (show val) + , spanText " ADA with id " + , spanText (show idCommit) + , spanText " to expire by " + , 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 + ] [ text "+" + ] + , spanText "Action " + , spanText (show idAction) + , spanText ": Claim " + , spanText (show val) + , spanText " ADA from commit " + , 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 + ] [ text "+" + ] + , spanText "Choice " + , spanText (show idChoice) + , spanText ": Choose value " + , 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 + ] [ text "+" + ] + , spanText "Oracle " + , spanText (show idOracle) + , spanText ": Provide " + , spanText (show value) + , spanText " as the value for block " + , spanText (show blockNumber) + ] + + --updateSuggestedAction :: -- Person -> -- Int ->