Add holes to blockly on block selection

marlowe-playground-client/src/Blockly/Events.js

@@ -11,7 +11,7 @@ exports._readProperty = function (nothing, just, property, event) {
     if (typeof event !== 'object') {
       return nothing;
     } else {
-      if (property in event && typeof event[property] !== 'undefined') {
+      if (property in event && typeof event[property] !== 'undefined' && event[property] !== null) {
         return just(event[property])
       } else {
         return nothing;

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

@@ -6,11 +6,13 @@ module Blockly.Events
   , FinishLoadingEvent
   , MoveEvent
   , UIEvent
+  , SelectEvent
   , element
   , newParentId
   , oldParentId
   , oldInputName
   , newInputName
+  , newElementId
   ) where
 
 import Data.Function.Uncurried (Fn4, runFn4)
@@ -84,6 +86,16 @@ If needed these properties are also available for MoveEvent
   blockId	string	UUID of block. The block can be found with workspace.getBlockById(event.blockId)
   group	string	UUID of group. Some events are part of an indivisible group, such as inserting a statement in a stack.
 -}
+------------------------------------------------------------
+foreign import data SelectEvent :: Type
+
+instance hasEventSelectEvent :: HasEvent SelectEvent where
+  fromEvent :: Event -> Maybe SelectEvent
+  fromEvent = readBlocklyEventType "selected"
+
+newElementId :: SelectEvent -> Maybe String
+newElementId = readProperty "newElementId"
+
 ------------------------------------------------------------
 -- This function let us check if a blockly event is of the desired type. It was inspired by unsafeReadProtoTagged
 -- and the reason it's unsafe, it's because there could be other objects that have a property called `type` with

marlowe-playground-client/src/Blockly/Internal.js

@@ -115,3 +115,12 @@ exports.centerOnBlock_ = function (workspace, blockId) {
 exports.hideChaff_ = function (blockly) {
   blockly.hideChaff();
 }
+
+exports.getBlockType_ = function (block) {
+  return block.type;
+}
+
+exports.updateToolbox_ = function (toolboxJson, workspace) {
+  workspace.updateToolbox(toolboxJson);
+}
+

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

@@ -4,6 +4,7 @@ import Prelude
 import Blockly.Toolbox (Toolbox, encodeToolbox)
 import Blockly.Types (Block, Blockly, BlocklyState, Workspace)
 import Data.Argonaut.Core (Json)
+import Data.Array (catMaybes)
 import Data.Maybe (Maybe(..))
 import Data.Newtype (class Newtype, unwrap)
 import Data.Symbol (SProxy(..))
@@ -22,7 +23,6 @@ import Web.DOM (Element)
 import Web.Event.EventTarget (EventListener)
 import Web.HTML (HTMLElement)
 
--- QUESTION: Should we move these under Blockly.Types??
 type GridConfig
   = { spacing :: Int
     , length :: Int
@@ -75,7 +75,6 @@ derive newtype instance monoidXML :: Monoid XML
 
 derive newtype instance eqXML :: Eq XML
 
--- END QUESTION
 foreign import getElementById_ :: EffectFn1 String HTMLElement
 
 foreign import createBlocklyInstance_ :: Effect Blockly
@@ -113,6 +112,10 @@ foreign import centerOnBlock_ :: EffectFn2 Workspace String Unit
 
 foreign import hideChaff_ :: EffectFn1 Blockly Unit
 
+foreign import getBlockType_ :: EffectFn1 Block String
+
+foreign import updateToolbox_ :: EffectFn2 Json Workspace Unit
+
 newtype ElementId
   = ElementId String
 
@@ -208,6 +211,12 @@ centerOnBlock = runEffectFn2 centerOnBlock_
 hideChaff :: Blockly -> Effect Unit
 hideChaff = runEffectFn1 hideChaff_
 
+getBlockType :: Block -> Effect String
+getBlockType = runEffectFn1 getBlockType_
+
+updateToolbox :: Toolbox -> Workspace -> Effect Unit
+updateToolbox toolbox = runEffectFn2 updateToolbox_ (encodeToolbox toolbox)
+
 data Pair
   = Pair String String
 
@@ -232,6 +241,13 @@ data Arg
   | DummyLeft
   | DummyCentre
 
+argType :: Arg -> Maybe ({ name :: String, check :: String })
+argType (Value { name, check }) = Just $ { name, check }
+
+argType (Statement { name, check }) = Just $ { name, check }
+
+argType _ = Nothing
+
 type_ :: SProxy "type"
 type_ = SProxy
 
@@ -314,6 +330,9 @@ defaultBlockDefinition =
   , mutator: Nothing
   }
 
+typedArguments :: BlockDefinition -> Array { name :: String, check :: String }
+typedArguments (BlockDefinition { args0 }) = catMaybes $ argType <$> args0
+
 xml :: forall p i. Node ( id :: String, style :: String ) p i
 xml = element (ElemName "xml")
 

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

@@ -1,10 +1,13 @@
 module Blockly.Toolbox
   ( Toolbox(..)
   , ToolboxBlock
-  , Category
+  , Category(..)
+  , CategoryFields
+  , defaultCategoryFields
   , encodeToolbox
   , block
   , category
+  , separator
   , leaf
   ) where
 
@@ -84,13 +87,19 @@ category name colour children =
 leaf :: String -> Category
 leaf _type = CategoryLeaf $ block _type
 
+separator :: Category
+separator = Separator Nothing
+
 data Category
   = Category CategoryFields (Array Category)
   | CategoryLeaf ToolboxBlock
+  | Separator (Maybe String)
+  -- NOTE: Even if the documentation has the posibility to add a label, in practice the
+  --       "label" type doesn't seem to be recognized.
+  | Label String (Maybe String)
 
 -- A category could also be one of these, but not worth to implement at the moment
 -- https://developers.google.com/blockly/guides/configure/web/toolbox#preset_blocks
--- https://developers.google.com/blockly/guides/configure/web/toolbox#separators
 -- https://developers.google.com/blockly/guides/configure/web/toolbox#buttons_and_labels
 encodeCategory :: Category -> Json
 encodeCategory (Category fields children) =
@@ -99,14 +108,43 @@ encodeCategory (Category fields children) =
         ( [ Tuple "kind" (A.fromString "category")
           , Tuple "name" (A.fromString fields.name)
           , Tuple "contents" (A.fromArray $ encodeCategory <$> children)
-          , Tuple "expanded" (A.fromString $ show fields.expanded)
           ]
             <> catMaybes
                 [ Tuple "toolboxitemid" <<< A.fromString <$> fields.toolboxitemid
                 , Tuple "colour" <<< A.fromString <$> fields.colour
                 , Tuple "categorystyle" <<< A.fromString <$> fields.categorystyle
+                , if fields.expanded then
+                    Just $ Tuple "expanded" (A.fromString "true")
+                  else
+                    Nothing
                 ]
         )
     )
 
 encodeCategory (CategoryLeaf b) = encodeBlock b
+
+encodeCategory (Separator mClassName) =
+  A.fromObject
+    ( Object.fromFoldable
+        ( [ Tuple "kind" (A.fromString "sep") ]
+            <> catMaybes
+                [ Tuple "cssConfig"
+                    <<< A.fromObject
+                    <<< Object.singleton "container"
+                    <<< A.fromString
+                    <$> mClassName
+                ]
+        )
+    )
+
+encodeCategory (Label text mClassName) =
+  A.fromObject
+    ( Object.fromFoldable
+        ( [ Tuple "kind" (A.fromString "label")
+          , Tuple "text" (A.fromString text)
+          ]
+            <> catMaybes
+                [ Tuple "web-class" <<< A.fromString <$> mClassName
+                ]
+        )
+    )

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

@@ -1,7 +1,7 @@
 module Blockly.Types where
 
 import Prelude
-import Blockly.Events (ChangeEvent, CreateEvent, FinishLoadingEvent, MoveEvent, UIEvent, element)
+import Blockly.Events (ChangeEvent, CreateEvent, FinishLoadingEvent, MoveEvent, UIEvent, element, SelectEvent)
 import Data.Maybe (Maybe(..))
 
 foreign import data Blockly :: Type
@@ -22,6 +22,7 @@ data BlocklyEvent
   | Move MoveEvent
   | FinishLoading FinishLoadingEvent
   | UI UIEvent
+  | Select SelectEvent
 
 isDragStart :: BlocklyEvent -> Boolean
 isDragStart (UI event) = element event == (Just "dragStart")

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

@@ -2,10 +2,12 @@ module BlocklyComponent.State (blocklyComponent) where
 
 import Prelude hiding (div)
 import Blockly.Dom (explainError, getDom)
+import Blockly.Events (newElementId)
 import Blockly.Generator (newBlock)
-import Blockly.Internal (BlockDefinition, ElementId(..), centerOnBlock, getBlockById, select)
+import Blockly.Internal (BlockDefinition, ElementId(..), centerOnBlock, getBlockById, getBlockType, select, updateToolbox)
 import Blockly.Internal as Blockly
 import Blockly.Toolbox (Toolbox)
+import Blockly.Types as BT
 import BlocklyComponent.Types (Action(..), Message(..), Query(..), State, _blocklyEventSubscription, _blocklyState, _errorMessage, blocklyRef, emptyState)
 import BlocklyComponent.View (render)
 import Control.Monad.Except (ExceptT(..), runExceptT, withExceptT)
@@ -16,7 +18,7 @@ import Data.Maybe (Maybe(..))
 import Data.Traversable (for, for_)
 import Effect.Aff.Class (class MonadAff)
 import Effect.Exception.Unsafe (unsafeThrow)
-import Halogen (Component, HalogenM, getHTMLElementRef, liftEffect, mkComponent, modify_)
+import Halogen (Component, HalogenM, getHTMLElementRef, liftEffect, mkComponent, modify_, raise)
 import Halogen as H
 import Halogen.BlocklyCommons (blocklyEvents, runWithoutEventSubscription, detectCodeChanges)
 import Halogen.ElementResize (elementResize)
@@ -117,6 +119,13 @@ handleQuery (SelectWarning warning next) = do
               centerOnBlock blocklyState.workspace blockId
   pure $ Just next
 
+handleQuery (SetToolbox toolbox next) = do
+  void
+    $ runMaybeT do
+        blocklyState <- MaybeT $ use _blocklyState
+        MaybeT $ map pure $ liftEffect $ updateToolbox toolbox blocklyState.workspace
+  pure $ Just next
+
 -- We cannot guarantee at the type level that the only type of location we handle in this editor
 -- is a BlockId location, so we throw a useful error if we ever get to this situation
 locationToBlockId :: Location -> String
@@ -154,6 +163,16 @@ handleAction (Inject rootBlockName blockDefinitions toolbox) = do
 
 handleAction (SetData _) = pure unit
 
+handleAction (BlocklyEvent (BT.Select event)) = case newElementId event of
+  Nothing -> raise $ BlockSelection Nothing
+  Just blockId -> do
+    void
+      $ runMaybeT do
+          blocklyState <- MaybeT $ use _blocklyState
+          block <- MaybeT $ liftEffect $ getBlockById blocklyState.workspace blockId
+          blockType <- MaybeT $ map pure $ liftEffect $ getBlockType block
+          MaybeT $ map pure $ raise $ BlockSelection $ Just $ { blockId, blockType }
+
 handleAction (BlocklyEvent event) = detectCodeChanges CodeChange event
 
 handleAction ResizeWorkspace = do

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

@@ -44,6 +44,7 @@ data Query a
   | LoadWorkspace XML a
   | GetBlockRepresentation (Block -> a)
   | SelectWarning Warning a
+  | SetToolbox Toolbox a
 
 data Action
   = Inject String (Array BlockDefinition) Toolbox
@@ -54,6 +55,7 @@ data Action
 
 data Message
   = CodeChange
+  | BlockSelection (Maybe ({ blockId :: String, blockType :: String }))
 
 blocklyRef :: RefLabel
 blocklyRef = RefLabel "blockly"

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

@@ -24,7 +24,7 @@ import Halogen (HalogenM, modify_, query)
 import Halogen as H
 import Halogen.Extra (mapSubmodule)
 import MainFrame.Types (ChildSlots, _blocklySlot)
-import Marlowe.Blockly (blockToContract)
+import Marlowe.Blockly as MB
 import Marlowe.Extended (TemplateContent)
 import Marlowe.Extended as EM
 import Marlowe.Holes as Holes
@@ -56,6 +56,14 @@ handleAction Init = do
 
 handleAction (HandleBlocklyMessage Blockly.CodeChange) = processBlocklyCode
 
+handleAction (HandleBlocklyMessage (Blockly.BlockSelection selection)) = case mBlockDefinition of
+  Nothing -> void $ query _blocklySlot unit $ H.tell (Blockly.SetToolbox MB.toolbox)
+  Just definition -> void $ query _blocklySlot unit $ H.tell (Blockly.SetToolbox $ MB.toolboxWithHoles definition)
+  where
+  mBlockDefinition = do
+    { blockType } <- selection
+    Map.lookup blockType MB.definitionsMap
+
 handleAction (InitBlocklyProject code) = do
   void $ query _blocklySlot unit $ H.tell (Blockly.SetCode code)
   liftEffect $ SessionStorage.setItem marloweBufferLocalStorageKey code
@@ -95,7 +103,7 @@ processBlocklyCode = do
   eContract <-
     runExceptT do
       block <- ExceptT <<< map (note "Blockly Workspace is empty") $ query _blocklySlot unit $ H.request Blockly.GetBlockRepresentation
-      except $ blockToContract block
+      except $ MB.blockToContract block
   case eContract of
     Left e ->
       modify_
@@ -138,7 +146,7 @@ runAnalysis doAnalyze =
     $ runMaybeT do
         block <- MaybeT $ query _blocklySlot unit $ H.request Blockly.GetBlockRepresentation
         -- FIXME: See if we can use runExceptT and show the error somewhere
-        contract <- MaybeT $ pure $ Holes.fromTerm =<< (hush $ blockToContract block)
+        contract <- MaybeT $ pure $ Holes.fromTerm =<< (hush $ MB.blockToContract block)
         lift do
           doAnalyze contract
           processBlocklyCode
@@ -147,5 +155,5 @@ editorGetValue :: forall state action msg m. HalogenM state action ChildSlots ms
 editorGetValue =
   runMaybeT do
     block <- MaybeT $ query _blocklySlot unit $ H.request Blockly.GetBlockRepresentation
-    contract <- hoistMaybe $ hush $ blockToContract block
+    contract <- hoistMaybe $ hush $ MB.blockToContract block
     pure $ show $ pretty $ contract

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

@@ -2,7 +2,6 @@ module BlocklyEditor.View where
 
 import Prelude hiding (div)
 import Blockly.Internal (block, blockType, style, x, xml, y)
-import Blockly.Toolbox (Toolbox(..), category, leaf)
 import BlocklyComponent.State as Blockly
 import BlocklyEditor.BottomPanel (panelContents)
 import BlocklyEditor.Types (Action(..), BottomPanelView(..), State, _bottomPanelState, _hasHoles, _marloweCode, _warnings)
@@ -31,7 +30,7 @@ render state =
     [ section
         [ classes [ paddingX, minH0, overflowHidden, fullHeight ]
         ]
-        [ slot _blocklySlot unit (Blockly.blocklyComponent MB.rootBlockName MB.blockDefinitions toolbox) unit (Just <<< HandleBlocklyMessage)
+        [ slot _blocklySlot unit (Blockly.blocklyComponent MB.rootBlockName MB.blockDefinitions MB.toolbox) unit (Just <<< HandleBlocklyMessage)
         , workspaceBlocks
         ]
     , section [ classes [ paddingX, maxH70p ] ]
@@ -54,19 +53,6 @@ render state =
 
   wrapBottomPanelContents panelView = BottomPanel.PanelAction <$> panelContents state panelView
 
-toolbox :: Toolbox
-toolbox =
-  CategoryToolbox
-    [ category "Contracts" MB.contractColour $ map (leaf <<< show) MB.contractTypes
-    , category "Observations" MB.observationColour $ map (leaf <<< show) MB.observationTypes
-    , category "Actions" MB.actionColour $ map (leaf <<< show) MB.actionTypes
-    , category "Values" MB.valueColour $ map (leaf <<< show) MB.valueTypes
-    , category "Payee" MB.payeeColour $ map (leaf <<< show) MB.payeeTypes
-    , category "Party" MB.partyColour $ map (leaf <<< show) MB.partyTypes
-    , category "Token" MB.tokenColour $ map (leaf <<< show) MB.tokenTypes
-    , category "Bounds" MB.boundsColour $ [ leaf $ show MB.BoundsType ]
-    ]
-
 workspaceBlocks :: forall a b. HTML a b
 workspaceBlocks =
   xml [ id_ "workspaceBlocks", style "display:none" ]

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

@@ -41,13 +41,14 @@ blocklyEvents toAction workspace =
         let
           mEvent =
             -- Blockly can fire all of the following events https://developers.google.com/blockly/guides/configure/web/events
-            -- but at the moment we only care for the ones that may affect the unsaved changes.
+            -- but at the moment we only care for the following ones
             oneOf
               [ BT.Create <$> fromEvent event
               , BT.Move <$> fromEvent event
               , BT.Change <$> fromEvent event
               , BT.FinishLoading <$> fromEvent event
               , BT.UI <$> fromEvent event
+              , BT.Select <$> fromEvent event
               ]
         in
           for_ mEvent \ev -> EventSource.emit emitter (toAction ev)