Merge branch 'master' into simulation-tab-names-fix

marlowe-playground-client/README.md

@@ -11,10 +11,9 @@ Check the [backend documentation](../marlowe-playground-server/README.md) for mo
 
 Now we will build and run the front end:
 ```bash
-# First generate the purescript bridge files
-$(nix-build -A marlowe-playground.server-invoker)/bin/marlowe-playground psgenerator ./marlowe-playground-client/generated
-# Now we will build and run the client on localhost
 cd marlowe-playground-client
+# Generate the purescript bridge files
+marlowe-playground-generate-purs
 # Download javascript dependencies
 npm install
 # Install purescript depdendencies

marlowe-playground-client/default.nix

@@ -39,6 +39,7 @@ let
   client = buildPursPackage {
     inherit webCommon nodeModules;
     src = ./.;
+    checkPhase = "npm run test";
     name = "marlowe-playground-client";
     psSrc = generated-purescript;
     packages = pkgs.callPackage ./packages.nix { };

marlowe-playground-client/package.json

@@ -7,7 +7,7 @@
     "webpack:server": "webpack-dev-server --progress --inline --hot --mode=development --host 0.0.0.0 --display verbose",
     "webpack:server:debug": "DEBUG=purs-loader* DEBUG_DEPTH=100 webpack-dev-server --progress --inline --hot",
     "purs:compile": "spago build",
-    "purs:ide": "purs ide server --log-level=debug 'src/**/*.purs' 'generated/**/*.purs' 'test/**/*.purs' '../web-common/**/*.purs'",
+    "purs:ide": "purs ide server --log-level=debug 'src/**/*.purs' 'generated/**/*.purs' 'test/**/*.purs' 'web-common/**/*.purs'",
     "test": "NODE_OPTIONS=\"--max-old-space-size=8192\" webpack --config webpack.test.config.js --mode=development && node --max-old-space-size=8192 dist/test.js",
     "docs": "spago docs",
     "repl": "spago repl"

marlowe-playground-client/spago.dhall

@@ -37,6 +37,6 @@ You can edit this file as you like.
   [ "src/**/*.purs"
   , "test/**/*.purs"
   , "generated/**/*.purs"
-  , "../web-common/**/*.purs"
+  , "web-common/**/*.purs"
   ]
 }

marlowe-playground-client/src/BlocklyEditor/State.purs

@@ -0,0 +1,51 @@
+module BlocklyEditor.State where
+
+import Prelude
+import BlocklyEditor.Types (Action(..), State, _errorMessage, _marloweCode)
+import Control.Monad.Except (ExceptT(..), except, runExceptT)
+import Data.Bifunctor (lmap)
+import Data.Either (note, Either(..))
+import Data.Lens (assign)
+import Data.Maybe (Maybe(..))
+import Debug.Trace (spy)
+import Effect.Aff.Class (class MonadAff)
+import Halogen (HalogenM, query)
+import Halogen as H
+import Halogen.Blockly as Blockly
+import MainFrame.Types (ChildSlots, _blocklySlot)
+import Marlowe.Parser as Parser
+import Text.Extra as Text
+import Text.Pretty (pretty)
+
+handleAction ::
+  forall m.
+  MonadAff m =>
+  Action ->
+  HalogenM State Action ChildSlots Void m Unit
+handleAction (HandleBlocklyMessage Blockly.CodeChange) = do
+  eContract <-
+    runExceptT do
+      code <- ExceptT <<< map (note "Blockly Workspace is empty") $ query _blocklySlot unit $ H.request Blockly.GetCode
+      except <<< lmap (unexpected <<< show) $ Parser.parseContract (Text.stripParens code)
+  case eContract of
+    Left e -> do
+      assign _errorMessage $ Just e
+      assign _marloweCode Nothing
+    Right contract -> do
+      assign _errorMessage Nothing
+      assign _marloweCode $ Just $ show $ pretty contract
+  where
+  unexpected s = "An unexpected error has occurred, please raise a support issue at https://github.com/input-output-hk/plutus/issues/new: " <> s
+
+handleAction (InitBlocklyProject code) = do
+  assign _marloweCode $ Just code
+  void $ query _blocklySlot unit $ H.tell (Blockly.SetCode code)
+
+handleAction SendToSimulator = pure unit
+
+handleAction ViewAsMarlowe = pure unit
+
+handleAction Save = pure unit
+
+editorGetValue :: forall state action msg m. HalogenM state action ChildSlots msg m (Maybe String)
+editorGetValue = query _blocklySlot unit $ H.request Blockly.GetCode

marlowe-playground-client/src/BlocklyEditor/Types.purs

@@ -0,0 +1,40 @@
+module BlocklyEditor.Types where
+
+import Prelude
+import Analytics (class IsEvent, defaultEvent)
+import Data.Lens (Lens')
+import Data.Lens.Record (prop)
+import Data.Maybe (Maybe(..))
+import Data.Symbol (SProxy(..))
+import Halogen.Blockly as Blockly
+
+data Action
+  = HandleBlocklyMessage Blockly.Message
+  | InitBlocklyProject String
+  | SendToSimulator
+  | ViewAsMarlowe
+  | Save
+
+instance blocklyActionIsEvent :: IsEvent Action where
+  toEvent (HandleBlocklyMessage _) = Just $ (defaultEvent "HandleBlocklyMessage") { category = Just "Blockly" }
+  toEvent (InitBlocklyProject _) = Just $ (defaultEvent "InitBlocklyProject") { category = Just "Blockly" }
+  toEvent SendToSimulator = Just $ (defaultEvent "SendToSimulator") { category = Just "Blockly" }
+  toEvent ViewAsMarlowe = Just $ (defaultEvent "ViewAsMarlowe") { category = Just "Blockly" }
+  toEvent Save = Just $ (defaultEvent "Save") { category = Just "Blockly" }
+
+type State
+  = { errorMessage :: Maybe String
+    , marloweCode :: Maybe String
+    }
+
+_errorMessage :: Lens' State (Maybe String)
+_errorMessage = prop (SProxy :: SProxy "errorMessage")
+
+_marloweCode :: Lens' State (Maybe String)
+_marloweCode = prop (SProxy :: SProxy "marloweCode")
+
+initialState :: State
+initialState =
+  { errorMessage: Nothing
+  , marloweCode: Nothing
+  }

marlowe-playground-client/src/BlocklyEditor/View.purs

@@ -0,0 +1,48 @@
+module BlocklyEditor.View where
+
+import Prelude hiding (div)
+import BlocklyEditor.Types (Action(..), State, _marloweCode)
+import Data.Lens ((^.))
+import Data.Maybe (Maybe(..), isJust)
+import Effect.Aff.Class (class MonadAff)
+import Halogen (ComponentHTML)
+import Halogen.Blockly as Blockly
+import Halogen.Classes (disabled, group)
+import Halogen.HTML (HTML, button, div, slot, text, div_)
+import Halogen.HTML.Events (onClick)
+import Halogen.HTML.Properties (classes, enabled)
+import MainFrame.Types (ChildSlots, _blocklySlot)
+import Marlowe.Blockly as MB
+
+render ::
+  forall m.
+  MonadAff m =>
+  State ->
+  ComponentHTML Action ChildSlots m
+render state =
+  div_
+    [ slot _blocklySlot unit (Blockly.blockly MB.rootBlockName MB.blockDefinitions) unit (Just <<< HandleBlocklyMessage)
+    , MB.toolbox
+    , MB.workspaceBlocks
+    ]
+
+otherActions ::
+  forall p.
+  State -> HTML p Action
+otherActions state =
+  div [ classes [ group ] ]
+    [ button
+        [ onClick $ const $ Just ViewAsMarlowe
+        , enabled hasCode
+        , classes [ disabled hasCode ]
+        ]
+        [ text "View as Marlowe" ]
+    , button
+        [ onClick $ const $ Just SendToSimulator
+        , enabled hasCode
+        , classes [ disabled hasCode ]
+        ]
+        [ text "Send To Simulator" ]
+    ]
+  where
+  hasCode = isJust $ state ^. _marloweCode

marlowe-playground-client/src/Halogen/Blockly.purs

@@ -27,7 +27,6 @@ import Marlowe.Holes (Term(..))
 import Marlowe.Parser as Parser
 import Prim.TypeError (class Warn, Text)
 import Text.Extra as Text
-import Text.Pretty (pretty)
 import Type.Proxy (Proxy(..))
 
 type State
@@ -73,9 +72,7 @@ type DSL slots m a
 
 blockly ::
   forall m.
-  Warn (Text "SCP-1646 Separate this file into BlocklyEditor.Types BlocklyEditor.View and BlocklyEditor.State") =>
-  MonadAff
-    m =>
+  MonadAff m =>
   String ->
   Array BlockDefinition ->
   Component HTML Query Unit Message m
@@ -112,7 +109,7 @@ handleQuery (SetCode code next) = do
     Just blocklyState -> do
       assign _useEvents false
       let
-        contract = case Parser.parseContract code of
+        contract = case Parser.parseContract (Text.stripParens code) of
           Right c -> c
           Left _ -> Hole blocklyState.rootBlockName Proxy zero
       pure $ ST.run (buildBlocks newBlock blocklyState contract)
@@ -141,7 +138,7 @@ handleQuery (LoadWorkspace xml next) = do
   pure $ Just next
 
 handleQuery (GetCode next) = do
-  res <-
+  eCode <-
     runExceptT do
       blocklyState <- ExceptT <<< map (note $ unexpected "BlocklyState not set") $ use _blocklyState
       generator <- ExceptT <<< map (note $ unexpected "Generator not set") $ use _generator
@@ -150,15 +147,14 @@ handleQuery (GetCode next) = do
 
         rootBlockName = blocklyState.rootBlockName
       block <- except <<< (note $ unexpected ("Can't find root block" <> rootBlockName)) $ getBlockById workspace rootBlockName
-      code <- except <<< lmap unexpected $ blockToCode block generator
-      except <<< lmap (unexpected <<< show) $ Parser.parseContract (Text.stripParens code)
-  case res of
+      except <<< lmap unexpected $ blockToCode block generator
+  case eCode of
     Left e -> do
       assign _errorMessage $ Just e
       pure Nothing
-    Right contract -> do
+    Right code -> do
       assign _errorMessage Nothing
-      pure $ Just $ next $ show $ pretty contract
+      pure <<< Just <<< next $ code
   where
   unexpected s = "An unexpected error has occurred, please raise a support issue at https://github.com/input-output-hk/plutus/issues/new: " <> s
 
@@ -196,7 +192,7 @@ handleAction (BlocklyEvent event) = updateUnsavedChangesActionHandler CodeChange
 blocklyRef :: RefLabel
 blocklyRef = RefLabel "blockly"
 
-render :: forall p. State -> HTML p Action
+render :: forall r p action. { errorMessage :: Maybe String | r } -> HTML p action
 render state =
   div []
     [ div

marlowe-playground-client/src/HaskellEditor/State.purs

@@ -67,17 +67,6 @@ handleAction _ (ShowBottomPanel val) = do
 
 handleAction _ SendResultToSimulator = pure unit
 
--- FIXME: I think we want to change this action to be called from the simulator
---        with the action "soon to be implemented" ViewAsBlockly
-handleAction _ SendResultToBlockly = do
-  mContract <- use _compilationResult
-  case mContract of
-    Success (Right result) -> do
-      let
-        source = view (_InterpreterResult <<< _result) result
-      void $ query _blocklySlot unit (Blockly.SetCode source unit)
-    _ -> pure unit
-
 handleAction _ (InitHaskellProject contents) = do
   editorSetValue contents
   liftEffect $ LocalStorage.setItem bufferLocalStorageKey contents

marlowe-playground-client/src/HaskellEditor/Types.purs

@@ -22,9 +22,6 @@ data Action
   | HandleEditorMessage Monaco.Message
   | ShowBottomPanel Boolean
   | SendResultToSimulator
-  -- FIXME: I think we want to change this action to be called from the simulator
-  --        with the action "soon to be implemented" ViewAsBlockly
-  | SendResultToBlockly
   | InitHaskellProject String
 
 defaultEvent :: String -> Event
@@ -36,7 +33,6 @@ instance actionIsEvent :: IsEvent Action where
   toEvent (HandleEditorMessage _) = Just $ defaultEvent "HandleEditorMessage"
   toEvent (ShowBottomPanel _) = Just $ defaultEvent "ShowBottomPanel"
   toEvent SendResultToSimulator = Just $ defaultEvent "SendResultToSimulator"
-  toEvent SendResultToBlockly = Just $ defaultEvent "SendResultToBlockly"
   toEvent (InitHaskellProject _) = Just $ defaultEvent "InitHaskellProject"
 
 type State

marlowe-playground-client/src/JavascriptEditor/State.purs

@@ -118,15 +118,6 @@ handleAction _ (ShowBottomPanel val) = do
 
 handleAction _ SendResultToSimulator = pure unit
 
-handleAction _ SendResultToBlockly = do
-  mContract <- use _compilationResult
-  case mContract of
-    CompiledSuccessfully result -> do
-      let
-        source = view (_result <<< to show) result
-      void $ query _blocklySlot unit (Blockly.SetCode source unit)
-    _ -> pure unit
-
 handleAction _ (InitJavascriptProject prunedContent) = do
   editorSetValue prunedContent
   liftEffect $ LocalStorage.setItem jsBufferLocalStorageKey prunedContent

marlowe-playground-client/src/JavascriptEditor/Types.purs

@@ -40,10 +40,6 @@ data Action
   | HandleEditorMessage Monaco.Message
   | ShowBottomPanel Boolean
   | SendResultToSimulator
-  -- FIXME: I think we want to change this action to be called from the simulator
-  --        with the action "soon to be implemented" ViewAsBlockly.
-  --        Actually, in the JavaScript editor there isn't even a button to send to blockly.
-  | SendResultToBlockly
   | InitJavascriptProject String
 
 defaultEvent :: String -> Event
@@ -55,7 +51,6 @@ instance actionIsEvent :: IsEvent Action where
   toEvent (HandleEditorMessage _) = Just $ defaultEvent "HandleEditorMessage"
   toEvent (ShowBottomPanel _) = Just $ defaultEvent "ShowBottomPanel"
   toEvent SendResultToSimulator = Just $ defaultEvent "SendResultToSimulator"
-  toEvent SendResultToBlockly = Just $ defaultEvent "SendResultToBlockly"
   toEvent (InitJavascriptProject _) = Just $ defaultEvent "InitJavascriptProject"
 
 type DecorationIds