View on GitHub
File Changes
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
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)
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
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

                      
toEvent (MarloweHandleEditorMessage _) = Nothing

                      
+
toEvent (MarloweHandleMonacoEditorMessage _) = Nothing
+

                      
toEvent (MarloweHandleDragEvent _) = Nothing

                      
toEvent (MarloweHandleDropEvent _) = Just $ defaultEvent "MarloweDropScript"
  saveMarloweBuffer text
  updateContractInState text

                      
+
handleAction (MarloweHandleMonacoEditorMessage _) = pure unit
+

                      
handleAction (MarloweHandleDragEvent event) = preventDefault event

                      
handleAction (MarloweHandleDropEvent event) = do
'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
+
  });
}

                      
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
+
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
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)
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 ]
          , 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

                      
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)
data HAction
  -- Haskell Editor
  = MarloweHandleEditorMessage AceMessage
+
  | MarloweHandleMonacoEditorMessage Monaco.Message
  | MarloweHandleDragEvent DragEvent
  | MarloweHandleDropEvent DragEvent
  | MarloweMoveToPosition Pos
  = ( 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"
_blocklySlot :: SProxy "blocklySlot"
_blocklySlot = SProxy

                      
+
_monacoSlot :: SProxy "monacoSlot"
+
_monacoSlot = SProxy
+

                      
-----------------------------------------------------------
data View
  = HaskellEditor
    background: $card-bg;
    border: none;
}
+

                      
+
.monaco-editor-container {
+
    width: 100%;
+
    height: 800px;
+
}
\ No newline at end of file