WIP - some syntax highlighting working

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

@@ -1 +1,68 @@
 module Halogen.Monaco where
+
+import Prelude
+
+import Data.Lens (view)
+import Data.Maybe (Maybe(..))
+import Debug.Trace (trace)
+import Effect.Class (class MonadEffect, liftEffect)
+import Halogen (HalogenM, RefLabel(..))
+import Halogen as H
+import Halogen.HTML (HTML, div)
+import Halogen.HTML.Properties (class_, ref)
+import Monaco (Monaco)
+import Monaco as Monaco
+import Monaco.Marlowe as MM
+
+type State
+  = { editor :: Maybe Monaco }
+
+data Query a
+  = Q a
+
+data Action
+  = Init
+
+data Message
+  = Initialized
+
+monacoComponent :: forall m. MonadEffect m => H.Component HTML Query Unit Message m
+monacoComponent =
+  H.mkComponent
+    { initialState: const { editor: Nothing }
+    , render
+    , eval:
+      H.mkEval
+        { handleAction
+        , handleQuery
+        , initialize: Just Init
+        , receive: const Nothing
+        , finalize: Nothing
+        }
+    }
+
+render :: forall p i. State -> HTML p i
+render state =
+  div
+    [ ref $ H.RefLabel "monacoEditor"
+    , class_ $ H.ClassName "monaco-editor-container"
+    ]
+    []
+
+handleAction :: forall slots m. MonadEffect m => Action -> HalogenM State Action slots Message m Unit
+handleAction Init = do
+  m <- liftEffect Monaco.getMonaco
+  maybeElement <- H.getHTMLElementRef (RefLabel "monacoEditor")
+  case maybeElement of
+    Just element -> do
+      trace element \_ -> pure unit
+      liftEffect $ Monaco.registerLanguage m MM.languageExtensionPoint
+      _ <- liftEffect $ Monaco.create m element (view MM._id MM.languageExtensionPoint)
+      liftEffect $ Monaco.setMonarchTokensProvider m (view MM._id MM.languageExtensionPoint) MM.monarchLanguage
+      _ <- H.modify (const { editor: Just m })
+      pure unit
+    Nothing -> pure unit
+  H.raise Initialized
+
+handleQuery :: forall a input m. Query a -> HalogenM State Action input Message m (Maybe a)
+handleQuery (Q next) = pure $ Just next

marlowe-playground-client/src/Main.purs

@@ -5,7 +5,6 @@ import Prelude
 import Control.Coroutine (Consumer, Process, connect, consumer, runProcess, ($$))
 import Control.Monad.Reader.Trans (runReaderT)
 import Data.Maybe (Maybe(..))
-import Debug.Trace (trace)
 import Effect (Effect)
 import Effect.Aff (forkAff, Aff)
 import Effect.Class (liftEffect)
@@ -14,7 +13,6 @@ import Effect.Unsafe (unsafePerformEffect)
 import Foreign.Generic (defaultOptions)
 import Halogen (hoist)
 import Halogen.Aff (awaitBody, runHalogenAff)
-import Monaco as Monaco
 import Halogen.VDom.Driver (runUI)
 import LocalStorage (RawStorageEvent)
 import LocalStorage as LocalStorage
@@ -41,8 +39,6 @@ ajaxSettings = SPSettings_ $ (settings { decodeJson = decodeJson, encodeJson = e
 main ::
   Effect Unit
 main = do
-  monaco <- Monaco.getMonaco
-  trace monaco \_ -> pure unit
   -- TODO: need to get the proper url, same as the client
   window <- W.window
   location <- WW.location window

marlowe-playground-client/src/MainFrame.purs

@@ -130,6 +130,8 @@ toEvent (HaskellEditorAction _) = Just $ (defaultEvent "ConfigureEditor")
 
 toEvent (MarloweHandleEditorMessage _) = Nothing
 
+toEvent (MarloweHandleMonacoEditorMessage _) = Nothing
+
 toEvent (MarloweHandleDragEvent _) = Nothing
 
 toEvent (MarloweHandleDropEvent _) = Just $ defaultEvent "MarloweDropScript"
@@ -205,6 +207,8 @@ handleAction (MarloweHandleEditorMessage (TextChanged text)) = do
   saveMarloweBuffer text
   updateContractInState text
 
+handleAction (MarloweHandleMonacoEditorMessage _) = pure unit
+
 handleAction (MarloweHandleDragEvent event) = preventDefault event
 
 handleAction (MarloweHandleDropEvent event) = do

marlowe-playground-client/src/Monaco.js

@@ -2,18 +2,23 @@
 'use strict';
 
 exports.getMonaco = function () {
-    return global.monaco;
+  return global.monaco;
 }
 
-exports.create_ = function(monaco, nodeId) {
-    return function() {
-        monaco.editor.create(document.getElementById(nodeId), {
-            value: [
-              'function x() {',
-              '\tconsole.log("Hello world!");',
-              '}'
-            ].join('\n'),
-            language: 'javascript'
-          });
-    }
+exports.registerLanguage_ = function(monaco, language) {
+  monaco.languages.register(language);
+}
+
+exports.setMonarchTokensProvider_ = function(monaco, languageId, languageDef) {
+  console.log(languageDef);
+  monaco.languages.setMonarchTokensProvider(languageId, languageDef);
+}
+
+exports.create_ = function (monaco, nodeId, languageId) {
+  monaco.editor.create(nodeId, {
+    value: [
+      'Close'
+    ].join('\n'),
+    language: languageId
+  });
 }

marlowe-playground-client/src/Monaco.purs

@@ -2,10 +2,137 @@ module Monaco where
 
 import Prelude
 
+import Data.Generic.Rep (class Generic)
+import Data.Maybe (Maybe(..))
+import Data.Newtype (class Newtype)
+import Data.String.Regex (Regex)
+import Data.Tuple (Tuple)
 import Effect (Effect)
+import Effect.Uncurried (EffectFn2, EffectFn3, runEffectFn2, runEffectFn3)
+import Foreign (unsafeToForeign)
+import Foreign.Generic (class Encode, Foreign, SumEncoding(..), defaultOptions, encode, genericEncode)
+import Foreign.Object (Object)
+import Foreign.Object as Object
+import Web.HTML (HTMLElement)
+
+class Default a where
+  default :: a
+
+newtype LanguageExtensionPoint
+  = LanguageExtensionPoint { id :: String }
+
+derive instance newtypeLanguageExtensionPoint :: Newtype LanguageExtensionPoint _
+
+derive instance genericLanguageExtensionPoint :: Generic LanguageExtensionPoint _
+
+derive newtype instance encodeLanguageExtensionPoint :: Encode LanguageExtensionPoint
+
+newtype MonarchLanguageBracket
+  = MonarchLanguageBracket { close :: String, open :: String, token :: String }
+
+derive instance newtypeMonarchLanguageBracket :: Newtype MonarchLanguageBracket _
+
+derive instance genericMonarchLanguageBracket :: Generic MonarchLanguageBracket _
+
+derive newtype instance encodeMonarchLanguageBracket :: Encode MonarchLanguageBracket
+
+data Action
+  = Action { token :: String, next :: Maybe String, log :: Maybe String }
+  | Cases { cases :: (Object String), log :: Maybe String }
+
+derive instance genericAction :: Generic Action _
+
+instance encodeAction :: Encode Action where
+  encode a =
+    let
+      sumEncoding =
+        TaggedObject
+          { tagFieldName: "tag"
+          , contentsFieldName: "contents"
+          , constructorTagTransform: identity
+          , unwrapRecords: true
+          }
+    in
+      genericEncode (defaultOptions { sumEncoding = sumEncoding }) a
+
+newtype LanguageRule
+  = LanguageRule { regex :: Regex, action :: Action }
+
+derive instance newtypeLanguageRule :: Newtype LanguageRule _
+
+derive instance genericLanguageRule :: Generic LanguageRule _
+
+instance encodeLanguageRule :: Encode LanguageRule where
+  encode (LanguageRule r) = encode { regex: unsafeToForeign r.regex, action: r.action }
+
+simpleRule :: Regex -> String -> LanguageRule
+simpleRule regex token = LanguageRule { regex, action: Action { token, next: Nothing, log: Nothing } }
+
+simpleRuleWithLog :: Regex -> String -> String -> LanguageRule
+simpleRuleWithLog regex token msg = LanguageRule { regex, action: Action { token, next: Nothing, log: Just msg } }
+
+simpleRuleWithAction :: Regex -> String -> String -> LanguageRule
+simpleRuleWithAction regex token next = LanguageRule { regex, action: Action { token, next: Just next, log: Nothing } }
+
+simpleRuleCases :: Regex -> Array (Tuple String String) -> LanguageRule
+simpleRuleCases regex cases = LanguageRule { regex, action: Cases { log: Nothing, cases: (Object.fromFoldable cases) } }
+
+simpleRuleCasesWithLog :: Regex -> String -> Array (Tuple String String) -> LanguageRule
+simpleRuleCasesWithLog regex msg cases = LanguageRule { regex, action: Cases { log: Just msg, cases: (Object.fromFoldable cases) } }
+
+newtype MonarchLanguage
+  = MonarchLanguage
+  { brackets :: Maybe (Array MonarchLanguageBracket)
+  , defaultToken :: Maybe String
+  , ignoreCase :: Maybe Boolean
+  , start :: Maybe String
+  , tokenPostfix :: Maybe String
+  , tokenizer :: Object (Array LanguageRule)
+  -- FIXME: I need to have any record key I want here, to be extensible
+  , keywords :: Maybe (Array String)
+  }
+
+derive instance newtypeMonarchLanguage :: Newtype MonarchLanguage _
+
+derive instance genericMonarchLanguage :: Generic MonarchLanguage _
+
+derive newtype instance encodeMonarchLanguage :: Encode MonarchLanguage
+
+instance defaultMonarchLanguage :: Default MonarchLanguage where
+  default =
+    MonarchLanguage
+      { brackets: Nothing
+      , defaultToken: Nothing
+      , ignoreCase: Nothing
+      , start: Nothing
+      , tokenPostfix: Nothing
+      , tokenizer: mempty
+      , keywords: Nothing
+      }
 
 foreign import data Monaco :: Type
 
 foreign import getMonaco :: Effect Monaco
 
-foreign import create_ :: Monaco -> String -> Effect Unit
+foreign import create_ :: EffectFn3 Monaco HTMLElement String Unit
+
+foreign import registerLanguage_ :: EffectFn2 Monaco Foreign Unit
+
+foreign import setMonarchTokensProvider_ :: EffectFn3 Monaco String Foreign Unit
+
+create :: Monaco -> HTMLElement -> String -> Effect Unit
+create = runEffectFn3 create_
+
+registerLanguage :: Monaco -> LanguageExtensionPoint -> Effect Unit
+registerLanguage monaco language =
+  let
+    languageF = encode language
+  in
+    runEffectFn2 registerLanguage_ monaco languageF
+
+setMonarchTokensProvider :: Monaco -> String -> MonarchLanguage -> Effect Unit
+setMonarchTokensProvider monaco languageId languageDef =
+  let
+    languageDefF = encode languageDef
+  in
+    runEffectFn3 setMonarchTokensProvider_ monaco languageId languageDefF

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

@@ -0,0 +1,49 @@
+module Monaco.Marlowe where
+
+import Prelude
+
+import Data.Lens (Lens')
+import Data.Lens.Iso.Newtype (_Newtype)
+import Data.Lens.Record (prop)
+import Data.Maybe (Maybe(..))
+import Data.Newtype as Newtype
+import Data.String.Regex.Flags (noFlags)
+import Data.String.Regex.Unsafe (unsafeRegex)
+import Data.Symbol (SProxy(..))
+import Data.Tuple (Tuple(..))
+import Data.Tuple.Nested ((/\))
+import Foreign.Object as Object
+import Monaco (LanguageExtensionPoint(..), MonarchLanguage(..), MonarchLanguageBracket(..), default, simpleRule, simpleRuleCases, simpleRuleWithAction, simpleRuleWithLog)
+
+languageExtensionPoint :: LanguageExtensionPoint
+languageExtensionPoint = LanguageExtensionPoint { id: "marlowe" }
+
+_id :: Lens' LanguageExtensionPoint String
+_id = _Newtype <<< prop (SProxy :: SProxy "id")
+
+monarchLanguage :: MonarchLanguage
+monarchLanguage =
+  let
+    tokenizer =
+      Object.fromFoldable
+        [ "root"
+            /\ [ simpleRuleCases (unsafeRegex "[A-Z][a-z$]*" noFlags) [ Tuple "@keywords" "keyword" ]
+              , simpleRule (unsafeRegex "[ \\t\\r\\n]+" noFlags) "white"
+              -- TODO: monaco version has /"([^"\\]|\\.)*$/ not sure exactly what this is
+              , simpleRuleWithLog (unsafeRegex "\"*$" noFlags) "string.invalid" "string.invalid"
+              , simpleRuleWithAction (unsafeRegex "\"" noFlags) "string.quote" "@string"
+              , simpleRule (unsafeRegex "[()]" noFlags) "@brackets"
+              ]
+        , "string"
+            /\ [ simpleRule (unsafeRegex """[^\\"]+""" noFlags) "string"
+              , simpleRuleWithAction (unsafeRegex "\"" noFlags) "string" "@pop"
+              ]
+        ]
+
+    brackets = Just [ MonarchLanguageBracket { open: "(", close: ")", token: "delimiter.parenthesis" } ]
+
+    keywords = Just [ "Close", "If" ]
+
+    lang r = r { tokenizer = tokenizer, brackets = brackets, defaultToken = Just "invalid", keywords = keywords }
+  in
+    Newtype.over MonarchLanguage lang default

marlowe-playground-client/src/Simulation.purs

@@ -29,6 +29,8 @@ import Halogen.HTML (ClassName(..), ComponentHTML, HTML, PropName(..), a, b_, br
 import Halogen.HTML.Events (onClick, onDragOver, onDrop, onValueChange)
 import Halogen.HTML.Properties (ButtonType(..), InputType(InputNumber), class_, classes, enabled, id_, placeholder, prop, type_, value)
 import Halogen.HTML.Properties.ARIA (role)
+import Halogen.Monaco (monacoComponent)
+import Halogen.Monaco as Monaco
 import Marlowe.Holes (Holes(..), MarloweHole(..), MarloweType(..), getMarloweConstructors)
 import Marlowe.Parser (transactionInputList, transactionWarningList)
 import Marlowe.Semantics (AccountId(..), Assets(..), Bound(..), ChoiceId(..), ChosenNum, CurrencySymbol, Input(..), Party, Payee(..), Payment(..), PubKey, Slot(..), SlotInterval(..), Token(..), TokenName, TransactionError, TransactionInput(..), TransactionWarning(..), ValueId(..), _accounts, _boundValues, _choices, inBounds, maxTime)
@@ -37,7 +39,7 @@ import Network.RemoteData (RemoteData(..), isLoading)
 import Prelude (class Show, bind, compare, const, flip, identity, mempty, not, pure, show, unit, zero, ($), (+), (<$>), (<<<), (<>), (>))
 import StaticData as StaticData
 import Text.Parsing.StringParser (runParser)
-import Types (ActionInput(..), ActionInputId, ChildSlots, FrontendState, HAction(..), MarloweError(..), MarloweState, _Head, _analysisState, _contract, _editorErrors, _editorPreferences, _holes, _marloweCompileResult, _marloweEditorSlot, _marloweState, _payments, _pendingInputs, _possibleActions, _selectedHole, _slot, _state, _transactionError, _transactionWarnings)
+import Types (ActionInput(..), ActionInputId, ChildSlots, FrontendState, HAction(..), MarloweError(..), MarloweState, _Head, _analysisState, _contract, _editorErrors, _editorPreferences, _holes, _marloweCompileResult, _marloweEditorSlot, _marloweState, _monacoSlot, _payments, _pendingInputs, _possibleActions, _selectedHole, _slot, _state, _transactionError, _transactionWarnings)
 
 paneHeader :: forall p. String -> HTML p HAction
 paneHeader s = h2 [ class_ $ ClassName "pane-header" ] [ text s ]
@@ -89,14 +91,15 @@ simulationPane state =
           , br_
           , errorList
           , analysisPane state
-          , div [id_ "monacoPane"] []
+          , div [] [ slot _monacoSlot unit monacoEditor unit (Just <<< MarloweHandleMonacoEditorMessage) ]
           ]
         ]
     )
   where
   marloweEditor =
     aceComponent (Editor.initEditor initialContents StaticData.marloweBufferLocalStorageKey editorPreferences)
       (Just Live)
+  monacoEditor = monacoComponent
 
   editorPreferences = view _editorPreferences state