Changed blockly toolbox XML representation for a JSON one

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

@@ -1,7 +1,9 @@
 module Blockly.Internal where
 
 import Prelude
+import Blockly.Toolbox (Toolbox, encodeToolbox)
 import Blockly.Types (Block, Blockly, BlocklyState, Workspace)
+import Data.Argonaut.Core (Json)
 import Data.Maybe (Maybe(..))
 import Data.Newtype (class Newtype, unwrap)
 import Data.Symbol (SProxy(..))
@@ -44,7 +46,7 @@ type Move
     }
 
 type WorkspaceConfig
-  = { toolbox :: HTMLElement
+  = { toolbox :: Json
     , collapse :: Boolean
     , comments :: Boolean
     , disable :: Boolean
@@ -116,16 +118,15 @@ newtype ElementId
 
 derive instance newtypeElementId :: Newtype ElementId _
 
-createBlocklyInstance :: String -> ElementId -> ElementId -> Effect BlocklyState
-createBlocklyInstance rootBlockName workspaceElementId toolboxElementId = do
+createBlocklyInstance :: String -> ElementId -> Toolbox -> Effect BlocklyState
+createBlocklyInstance rootBlockName workspaceElementId toolbox = do
   blockly <- createBlocklyInstance_
-  toolbox <- runEffectFn1 getElementById_ (unwrap toolboxElementId)
-  workspace <- runEffectFn3 createWorkspace_ blockly (unwrap workspaceElementId) (config toolbox)
+  workspace <- runEffectFn3 createWorkspace_ blockly (unwrap workspaceElementId) config
   runEffectFn2 debugBlockly_ (unwrap workspaceElementId) { blockly, workspace, rootBlockName }
   pure { blockly, workspace, rootBlockName }
   where
-  config toolbox =
-    { toolbox: toolbox
+  config =
+    { toolbox: encodeToolbox toolbox
     , collapse: true
     , comments: true
     , disable: true
@@ -316,9 +317,6 @@ defaultBlockDefinition =
 xml :: forall p i. Node ( id :: String, style :: String ) p i
 xml = element (ElemName "xml")
 
-category :: forall p i. Node ( name :: String, colour :: String ) p i
-category = element (ElemName "category")
-
 block :: forall p i. Node ( id :: String, type :: String, x :: String, y :: String ) p i
 block = element (ElemName "block")
 

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

@@ -0,0 +1,112 @@
+module Blockly.Toolbox
+  ( Toolbox(..)
+  , ToolboxBlock
+  , Category
+  , encodeToolbox
+  , block
+  , category
+  , leaf
+  ) where
+
+import Prelude
+import Data.Argonaut.Core (Json)
+import Data.Argonaut.Core as A
+import Data.Array (catMaybes)
+import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..))
+import Foreign.Object as Object
+
+data Toolbox
+  = FlyoutToolbox (Array ToolboxBlock)
+  | CategoryToolbox (Array Category)
+
+encodeToolbox :: Toolbox -> Json
+encodeToolbox (FlyoutToolbox xs) =
+  A.fromObject
+    ( Object.fromFoldable
+        [ Tuple "kind" (A.fromString "flyoutToolbox")
+        , Tuple "contents" (A.fromArray $ encodeBlock <$> xs)
+        ]
+    )
+
+encodeToolbox (CategoryToolbox xs) =
+  A.fromObject
+    ( Object.fromFoldable
+        [ Tuple "kind" (A.fromString "categoryToolbox")
+        , Tuple "contents" (A.fromArray $ encodeCategory <$> xs)
+        ]
+    )
+
+type ToolboxBlock
+  = { type :: String
+    }
+
+encodeBlock :: ToolboxBlock -> Json
+encodeBlock b =
+  A.fromObject
+    ( Object.fromFoldable
+        [ Tuple "kind" (A.fromString "block")
+        , Tuple "type" (A.fromString b.type)
+        ]
+    )
+
+block :: String -> ToolboxBlock
+block _type = { type: _type }
+
+type CategoryFields
+  = { name :: String
+    , toolboxitemid :: Maybe String
+    , colour :: Maybe String
+    , categorystyle :: Maybe String
+    -- https://developers.google.com/blockly/guides/configure/web/toolbox#expanded
+    , expanded :: Boolean -- (default to false) (encoded as string)
+    -- Categories can also have this properties that we don't need to implement at the moment
+    -- cssConfig :: Object String
+    -- https://developers.google.com/blockly/guides/configure/web/toolbox#dynamic_categories
+    -- custom :: Maybe String
+    }
+
+defaultCategoryFields :: CategoryFields
+defaultCategoryFields =
+  { name: ""
+  , toolboxitemid: Nothing
+  , colour: Nothing
+  , categorystyle: Nothing
+  , expanded: false
+  }
+
+category :: String -> String -> Array Category -> Category
+category name colour children =
+  Category
+    (defaultCategoryFields { name = name, colour = Just colour })
+    children
+
+leaf :: String -> Category
+leaf _type = CategoryLeaf $ block _type
+
+data Category
+  = Category CategoryFields (Array Category)
+  | CategoryLeaf ToolboxBlock
+
+-- 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) =
+  A.fromObject
+    ( Object.fromFoldable
+        ( [ 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
+                ]
+        )
+    )
+
+encodeCategory (CategoryLeaf b) = encodeBlock b

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

@@ -5,6 +5,7 @@ import Blockly.Dom (explainError, getDom)
 import Blockly.Generator (newBlock)
 import Blockly.Internal (BlockDefinition, ElementId(..), centerOnBlock, getBlockById, select)
 import Blockly.Internal as Blockly
+import Blockly.Toolbox (Toolbox)
 import BlocklyComponent.Types (Action(..), Message(..), Query(..), State, _blocklyEventSubscription, _blocklyState, _errorMessage, blocklyRef, emptyState)
 import BlocklyComponent.View (render)
 import Control.Monad.Except (ExceptT(..), runExceptT, withExceptT)
@@ -35,16 +36,17 @@ blocklyComponent ::
   MonadAff m =>
   String ->
   Array BlockDefinition ->
+  Toolbox ->
   Component HTML Query Unit Message m
-blocklyComponent rootBlockName blockDefinitions =
+blocklyComponent rootBlockName blockDefinitions toolbox =
   mkComponent
     { initialState: const emptyState
     , render
     , eval:
         H.mkEval
           { handleQuery
           , handleAction
-          , initialize: Just $ Inject rootBlockName blockDefinitions
+          , initialize: Just $ Inject rootBlockName blockDefinitions toolbox
           , finalize: Nothing
           , receive: Just <<< SetData
           }
@@ -129,13 +131,13 @@ handleAction ::
   MonadAff m =>
   Action ->
   HalogenM State Action slots Message m Unit
-handleAction (Inject rootBlockName blockDefinitions) = do
+handleAction (Inject rootBlockName blockDefinitions toolbox) = do
   mElement <- (pure <<< map HTMLElement.toElement) =<< getHTMLElementRef blocklyRef
   blocklyState <-
     liftEffect do
       -- TODO: once we refactor ActusBlockly to use BlocklyComponent we should remove ElementId from
       --       createBlocklyInstance and receive two HTMLElements that should be handled by RefElement
-      state <- Blockly.createBlocklyInstance rootBlockName (ElementId "blocklyWorkspace") (ElementId "blocklyToolbox")
+      state <- Blockly.createBlocklyInstance rootBlockName (ElementId "blocklyWorkspace") toolbox
       Blockly.addBlockTypes state.blockly blockDefinitions
       Blockly.initializeWorkspace state.blockly state.workspace
       pure state

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

@@ -3,6 +3,7 @@ module BlocklyComponent.Types where
 import Prelude hiding (div)
 import Blockly.Dom (Block)
 import Blockly.Internal (BlockDefinition, XML)
+import Blockly.Toolbox (Toolbox)
 import Blockly.Types as BT
 import Data.Lens (Lens')
 import Data.Lens.Record (prop)
@@ -45,7 +46,7 @@ data Query a
   | SelectWarning Warning a
 
 data Action
-  = Inject String (Array BlockDefinition)
+  = Inject String (Array BlockDefinition) Toolbox
   | SetData Unit
   | BlocklyEvent BT.BlocklyEvent
   | ResizeWorkspace

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

@@ -1,7 +1,8 @@
 module BlocklyEditor.View where
 
 import Prelude hiding (div)
-import Blockly.Internal (block, blockType, category, colour, name, style, x, xml, y)
+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)
@@ -30,8 +31,7 @@ render state =
     [ section
         [ classes [ paddingX, minH0, overflowHidden, fullHeight ]
         ]
-        [ slot _blocklySlot unit (Blockly.blocklyComponent MB.rootBlockName MB.blockDefinitions) unit (Just <<< HandleBlocklyMessage)
-        , toolbox
+        [ slot _blocklySlot unit (Blockly.blocklyComponent MB.rootBlockName MB.blockDefinitions toolbox) unit (Just <<< HandleBlocklyMessage)
         , workspaceBlocks
         ]
     , section [ classes [ paddingX, maxH70p ] ]
@@ -54,21 +54,18 @@ render state =
 
   wrapBottomPanelContents panelView = BottomPanel.PanelAction <$> panelContents state panelView
 
-toolbox :: forall a b. HTML a b
+toolbox :: Toolbox
 toolbox =
-  xml [ id_ "blocklyToolbox", style "display:none" ]
-    [ category [ name "Contracts", colour MB.contractColour ] (map mkBlock MB.contractTypes)
-    , category [ name "Observations", colour MB.observationColour ] (map mkBlock MB.observationTypes)
-    , category [ name "Actions", colour MB.actionColour ] (map mkBlock MB.actionTypes)
-    , category [ name "Values", colour MB.valueColour ] (map mkBlock MB.valueTypes)
-    , category [ name "Payee", colour MB.payeeColour ] (map mkBlock MB.payeeTypes)
-    , category [ name "Party", colour MB.partyColour ] (map mkBlock MB.partyTypes)
-    , category [ name "Token", colour MB.tokenColour ] (map mkBlock MB.tokenTypes)
-    , category [ name "Bounds", colour MB.boundsColour ] (map mkBlock [ MB.BoundsType ])
+  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 ]
     ]
-  where
-  mkBlock :: forall t. Show t => t -> _
-  mkBlock t = block [ blockType (show t) ] []
 
 workspaceBlocks :: forall a b. HTML a b
 workspaceBlocks =

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

@@ -4,6 +4,7 @@ import Prelude hiding (div)
 import Blockly.Generator (Generator, blockToCode)
 import Blockly.Internal (BlockDefinition, ElementId(..), XML, getBlockById)
 import Blockly.Internal as Blockly
+import Blockly.Toolbox (Toolbox)
 import Blockly.Types as BT
 import Control.Monad.Except (ExceptT(..), except, runExceptT)
 import Data.Bifunctor (lmap)
@@ -69,7 +70,7 @@ data ContractFlavour
   | F
 
 data Action
-  = Inject String (Array BlockDefinition)
+  = Inject String (Array BlockDefinition) Toolbox
   | GetTerms ContractFlavour
   | BlocklyEvent BT.BlocklyEvent
   | RunAnalysis
@@ -83,8 +84,14 @@ type DSL m a
   = HalogenM State Action () Message m a
 
 -- FIXME: rename to mkBlockly to avoid shadowing in handleQuery
-blockly :: forall m. MonadAff m => String -> Array BlockDefinition -> Component HTML Query Unit Message m
-blockly rootBlockName blockDefinitions =
+blockly ::
+  forall m.
+  MonadAff m =>
+  String ->
+  Array BlockDefinition ->
+  Toolbox ->
+  Component HTML Query Unit Message m
+blockly rootBlockName blockDefinitions toolbox =
   mkComponent
     { initialState:
         const
@@ -99,7 +106,7 @@ blockly rootBlockName blockDefinitions =
         H.mkEval
           { handleQuery
           , handleAction
-          , initialize: Just $ Inject rootBlockName blockDefinitions
+          , initialize: Just $ Inject rootBlockName blockDefinitions toolbox
           , finalize: Nothing
           , receive: const Nothing
           }
@@ -130,10 +137,10 @@ handleQuery (LoadWorkspace xml next) = do
   pure $ Just next
 
 handleAction :: forall m. MonadAff m => Action -> DSL m Unit
-handleAction (Inject rootBlockName blockDefinitions) = do
+handleAction (Inject rootBlockName blockDefinitions toolbox) = do
   blocklyState /\ generator <-
     liftEffect do
-      state <- Blockly.createBlocklyInstance rootBlockName (ElementId "actusBlocklyWorkspace") (ElementId "actusBlocklyToolbox")
+      state <- Blockly.createBlocklyInstance rootBlockName (ElementId "actusBlocklyWorkspace") toolbox
       Blockly.addBlockTypes state.blockly blockDefinitions
       Blockly.initializeWorkspace state.blockly state.workspace
       generator <- buildGenerator state.blockly

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

@@ -58,8 +58,7 @@ render state =
               , tabContents JSEditor [ renderSubmodule _javascriptState JavascriptAction JSEditor.render state ]
               , tabContents BlocklyEditor [ renderSubmodule _blocklyEditorState BlocklyEditorAction BlocklyEditor.render state ]
               , tabContents ActusBlocklyEditor
-                  [ slot _actusBlocklySlot unit (ActusBlockly.blockly AMB.rootBlockName AMB.blockDefinitions) unit (Just <<< HandleActusBlocklyMessage)
-                  , AMB.toolbox
+                  [ slot _actusBlocklySlot unit (ActusBlockly.blockly AMB.rootBlockName AMB.blockDefinitions AMB.toolbox) unit (Just <<< HandleActusBlocklyMessage)
                   , AMB.workspaceBlocks
                   ]
               , tabContents WalletEmulator

marlowe-playground-client/src/Marlowe/ActusBlockly.purs

@@ -2,8 +2,9 @@ module Marlowe.ActusBlockly where
 
 import Prelude
 import Blockly.Generator (Generator, getFieldValue, getType, insertGeneratorFunction, mkGenerator, statementToCode)
-import Blockly.Internal (AlignDirection(..), Arg(..), BlockDefinition(..), block, blockType, category, colour, defaultBlockDefinition, name, style, x, xml, y)
-import Blockly.Types (Block, Blockly, BlocklyState)
+import Blockly.Internal (AlignDirection(..), Arg(..), BlockDefinition(..), block, blockType, defaultBlockDefinition, style, x, xml, y)
+import Blockly.Types (Block, Blockly)
+import Blockly.Toolbox (Toolbox(..), category, leaf)
 import Control.Alternative ((<|>))
 import Control.Monad.Except (runExcept)
 import Data.Bifunctor (lmap, rmap)
@@ -453,16 +454,13 @@ toDefinition (ActusPeriodType PeriodYearType) =
         }
         defaultBlockDefinition
 
-toolbox :: forall a b. HTML a b
+toolbox :: Toolbox
 toolbox =
-  xml [ id_ "actusBlocklyToolbox", style "display:none" ]
-    [ category [ name "Contracts", colour actusColour ] (map mkBlock actusContractTypes)
-    , category [ name "Values", colour valueColour ] (map mkBlock actusValueTypes)
-    , category [ name "Periods", colour periodColour ] (map mkBlock actusPeriodTypes)
+  CategoryToolbox
+    [ category "Contracts" actusColour $ map (leaf <<< show) actusContractTypes
+    , category "Values" valueColour $ map (leaf <<< show) actusValueTypes
+    , category "Periods" periodColour $ map (leaf <<< show) actusPeriodTypes
     ]
-  where
-  mkBlock :: forall t. Show t => t -> _
-  mkBlock t = block [ blockType (show t) ] []
 
 workspaceBlocks :: forall a b. HTML a b
 workspaceBlocks =

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

@@ -9,9 +9,8 @@ import Control.Monad.Error.Class (catchError)
 import Control.Monad.Error.Extra (toMonadThrow)
 import Control.Monad.Except (class MonadError, throwError)
 import Control.Monad.Except.Trans (class MonadThrow)
-import Data.Array (filter, head, length, uncons)
+import Data.Array (filter, head, uncons)
 import Data.Array as Array
-import Data.Array.Partial as UnsafeArray
 import Data.Bifunctor (lmap)
 import Data.BigInteger (BigInteger)
 import Data.BigInteger as BigInteger