diff --git a/marlowe-playground-client/src/Halogen/Monaco.purs b/marlowe-playground-client/src/Halogen/Monaco.purs index f8821066d84..9fd77ed5cb7 100644 --- a/marlowe-playground-client/src/Halogen/Monaco.purs +++ b/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 diff --git a/marlowe-playground-client/src/Main.purs b/marlowe-playground-client/src/Main.purs index 3773213fccf..2a33a4957f5 100644 --- a/marlowe-playground-client/src/Main.purs +++ b/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 diff --git a/marlowe-playground-client/src/MainFrame.purs b/marlowe-playground-client/src/MainFrame.purs index 54ba32bd0c1..af7925f3b2e 100644 --- a/marlowe-playground-client/src/MainFrame.purs +++ b/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 diff --git a/marlowe-playground-client/src/Monaco.js b/marlowe-playground-client/src/Monaco.js index a0763738aa9..a5431b65f38 100644 --- a/marlowe-playground-client/src/Monaco.js +++ b/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 + }); } diff --git a/marlowe-playground-client/src/Monaco.purs b/marlowe-playground-client/src/Monaco.purs index 3afc510d962..9a4be24dd58 100644 --- a/marlowe-playground-client/src/Monaco.purs +++ b/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 \ No newline at end of file +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 diff --git a/marlowe-playground-client/src/Monaco/Marlowe.purs b/marlowe-playground-client/src/Monaco/Marlowe.purs new file mode 100644 index 00000000000..03687c9e0fd --- /dev/null +++ b/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 diff --git a/marlowe-playground-client/src/Simulation.purs b/marlowe-playground-client/src/Simulation.purs index 21cf3f6c3c8..d269cf10f7d 100644 --- a/marlowe-playground-client/src/Simulation.purs +++ b/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,7 +91,7 @@ simulationPane state = , br_ , errorList , analysisPane state - , div [id_ "monacoPane"] [] + , div [] [ slot _monacoSlot unit monacoEditor unit (Just <<< MarloweHandleMonacoEditorMessage) ] ] ] ) @@ -97,6 +99,7 @@ simulationPane state = marloweEditor = aceComponent (Editor.initEditor initialContents StaticData.marloweBufferLocalStorageKey editorPreferences) (Just Live) + monacoEditor = monacoComponent editorPreferences = view _editorPreferences state diff --git a/marlowe-playground-client/src/Types.purs b/marlowe-playground-client/src/Types.purs index 1483d71c529..64c32c2ce16 100644 --- a/marlowe-playground-client/src/Types.purs +++ b/marlowe-playground-client/src/Types.purs @@ -27,6 +27,7 @@ import Gist (Gist) import Gists (GistAction) import Halogen as H import Halogen.Blockly (BlocklyQuery, BlocklyMessage) +import Halogen.Monaco as Monaco import Language.Haskell.Interpreter (InterpreterError, InterpreterResult) import Marlowe.Holes (Holes, MarloweHole) import Marlowe.Semantics (AccountId, Action(..), Assets, Bound, ChoiceId, ChosenNum, Contract, Environment(..), Input, Party, Payment, PubKey, Slot, SlotInterval(..), State, Token, TransactionError, TransactionWarning, _minSlot, boundFrom, emptyState, evalValue) @@ -48,6 +49,7 @@ data HQuery a data HAction -- Haskell Editor = MarloweHandleEditorMessage AceMessage + | MarloweHandleMonacoEditorMessage Monaco.Message | MarloweHandleDragEvent DragEvent | MarloweHandleDropEvent DragEvent | MarloweMoveToPosition Pos @@ -85,6 +87,7 @@ type ChildSlots = ( haskellEditorSlot :: H.Slot AceQuery AceMessage Unit , marloweEditorSlot :: H.Slot AceQuery AceMessage Unit , blocklySlot :: H.Slot BlocklyQuery BlocklyMessage Unit + , monacoSlot :: H.Slot Monaco.Query Monaco.Message Unit ) _haskellEditorSlot :: SProxy "haskellEditorSlot" @@ -96,6 +99,9 @@ _marloweEditorSlot = SProxy _blocklySlot :: SProxy "blocklySlot" _blocklySlot = SProxy +_monacoSlot :: SProxy "monacoSlot" +_monacoSlot = SProxy + ----------------------------------------------------------- data View = HaskellEditor diff --git a/marlowe-playground-client/static/main.scss b/marlowe-playground-client/static/main.scss index ae8655b2eeb..de7fdf77f8c 100644 --- a/marlowe-playground-client/static/main.scss +++ b/marlowe-playground-client/static/main.scss @@ -183,3 +183,8 @@ background: $card-bg; border: none; } + +.monaco-editor-container { + width: 100%; + height: 800px; +} \ No newline at end of file