diff --git a/CHANGELOG.md b/CHANGELOG.md index cad667104..7ef6d4804 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,9 @@ ## Unreleased +- Add experimental + [earlybird bytecode debugger](https://github.com/hackwaly/ocamlearlybird) + integration (#1148) - Trim whitespace when running `Evaluate Selection` command (#1100) - Encode URI when sending the `switchImplIntf` request (#983) diff --git a/README.md b/README.md index 64ada1657..076679410 100644 --- a/README.md +++ b/README.md @@ -203,6 +203,8 @@ to `ocamllsp`. - OCamllex - Task Provider - Dune +- Debugger + - Earlybird (experimental) ## Configuration @@ -261,6 +263,50 @@ prefix `OCaml:`: | `ocaml.open-repl` | Open REPL | | | `ocaml.evaluate-selection` | Evaluate Selection | `Shift+Enter` | +## Debugging OCaml programs (experimental) + +Experimental support for debugging OCaml programs is provided via +[earlybird](https://github.com/hackwaly/ocamlearlybird). Problems with the +debugger should be reported at . + +Two steps to set up debugging: + +1. Install [earlybird](https://opam.ocaml.org/packages/earlybird/), which + provides the `ocamlearlybird` executable. + + For newer OCaml version support, opam pin the development version from + . + +2. Build _bytecode_ version of your OCaml program executable. + + See + [dune documentation](https://dune.readthedocs.io/en/stable/quick-start.html#building-a-hello-world-program-in-bytecode) + for further information. + +There are three ways to launch the debugger in VS Code: + +1. Navigate to the built OCaml bytecode executable in VS Code Explorer panel (a + `.bc` file in `_build` directory), right click on it and select "Start OCaml + Debugging (experimental)". + + The debugger launches immediately. + +2. If no VS Code launch configurations (the `.vscode/launch.json` file) exist, + then navigate to VS Code Run and Debug panel, click on "create a launch.json + file" and select "OCaml earlybird (experimental)". + + Run the created "OCaml earlybird (experimental)" launch configuration to + launch the debugger. By default, it asks to open an OCaml bytecode executable + (a `.bc` file in `_build` directory) to debug. You can hard-code a specific + program instead of the default `${command:AskProgram}`. + +3. If some VS Code launch configurations exist (in `.vscode/launch.json`), then + open the `launch.json` file and inside `configurations` press Ctrl+Space to + select the "OCaml earlybird (experimental)" snippet. Then fill in the OCaml + bytecode executable path and desired launch configuration name. + + Run the created launch configuration to launch the debugger. + ## Debugging the extension ### Problems with code or file formatting support diff --git a/package.json b/package.json index ba138056a..6731a9106 100644 --- a/package.json +++ b/package.json @@ -18,7 +18,8 @@ "vscode": "^1.64.0" }, "categories": [ - "Programming Languages" + "Programming Languages", + "Debuggers" ], "activationEvents": [ "onLanguage:ocaml", @@ -37,6 +38,9 @@ "onCommand:ocaml.show-preprocessed-document", "onCommand:ocaml.open-pp-editor-and-ast-explorer", "onCommand:ocaml.stop-documentation-server", + "onCommand:ocaml.start-debugging", + "onCommand:ocaml.goto-closure-code-location", + "onCommand:ocaml.ask-debug-program", "onCustomEditor:ast-editor", "onCustomEditor:cm-files-editor", "workspaceContains:**/dune-workspace", @@ -48,7 +52,8 @@ "workspaceContains:**/*.mll", "workspaceContains:**/*.mly", "workspaceContains:**/*.re", - "workspaceContains:**/*.rei" + "workspaceContains:**/*.rei", + "onDebugResolve:ocaml.earlybird" ], "icon": "assets/logo.png", "contributes": { @@ -267,6 +272,16 @@ "command": "ocaml.open-ocaml-commands-output", "category": "OCaml", "title": "Show OCaml Commands Output" + }, + { + "command": "ocaml.start-debugging", + "category": "OCaml", + "title": "Start OCaml Debugging (experimental)" + }, + { + "command": "ocaml.goto-closure-code-location", + "category": "OCaml", + "title": "Goto Closure Code Location" } ], "keybindings": [ @@ -390,6 +405,14 @@ { "command": "ocaml.generate-sandbox-documentation", "when": "false" + }, + { + "command": "ocaml.start-debugging", + "when": "false" + }, + { + "command": "ocaml.goto-closure-code-location", + "when": "false" } ], "editor/title": [ @@ -448,6 +471,19 @@ "when": "view == ocaml-sandbox", "group": "inline@3" } + ], + "explorer/context": [ + { + "command": "ocaml.start-debugging", + "when": "resourceFilename =~ /\\.bc$/" + } + ], + "debug/variables/context": [ + { + "command": "ocaml.goto-closure-code-location", + "when": "debugProtocolVariableMenuContext == 'ocamlearlybird.function'", + "group": "navigation" + } ] }, "configuration": { @@ -1020,6 +1056,127 @@ } ] } + ], + "breakpoints": [ + { + "language": "ocaml" + }, + { + "language": "reason" + }, + { + "language": "ocaml.ocamllex" + }, + { + "language": "ocaml.menhir" + } + ], + "debuggers": [ + { + "type": "ocaml.earlybird", + "label": "OCaml earlybird (experimental)", + "configurationAttributes": { + "launch": { + "required": [ + "program" + ], + "properties": { + "cwd": { + "type": "string", + "description": "The working directory for debuggee program." + }, + "env": { + "type": "object", + "additionalProperties": { + "type": "string" + }, + "description": "Environment variables passed to the debuggee program.", + "default": {} + }, + "program": { + "type": "string", + "description": "The path of debuggee program." + }, + "source_dirs": { + "type": "array", + "items": { + "type": "string" + }, + "description": "The path to search sources.", + "default": [] + }, + "onlyDebugGlob": { + "type": "string", + "description": "Only debug sources which match `onlyDebugGlob`.", + "default": "true" + }, + "followForkMode": { + "enum": [ + "forkChild", + "forkParent" + ], + "description": "Set which process the debugger follows on fork.", + "default": "forkParent" + }, + "yieldSteps": { + "type": "number", + "description": "Max steps to execute in batch. Debugger can not response other requests when executing steps in batch.", + "default": 4096 + }, + "arguments": { + "type": "array", + "items": { + "type": "string" + }, + "description": "The command-line arguments for the debuggee program.", + "default": [] + }, + "console": { + "enum": [ + "internalConsole", + "integratedTerminal", + "externalTerminal" + ], + "description": "Where to launch the debug target: internal console, integrated terminal, or external terminal.", + "default": "internalConsole" + }, + "stopOnEntry": { + "type": "boolean", + "description": "Automatically stop after launch.", + "default": false + }, + "_debugLog": { + "type": "string", + "description": "File to Log debug messages." + } + } + } + }, + "initialConfigurations": [ + { + "name": "OCaml earlybird (experimental)", + "type": "ocaml.earlybird", + "request": "launch", + "program": "${command:AskProgram}", + "stopOnEntry": true + } + ], + "configurationSnippets": [ + { + "label": "OCaml earlybird (experimental)", + "description": "A new configuration for launching OCaml earlybird debug program", + "body": { + "name": "${2:OCaml earlybird (experimental)}", + "type": "ocaml.earlybird", + "request": "launch", + "program": "^\"\\${workspaceFolder}/${1:OCaml Bytecode Executable}\"" + } + } + ], + "variables": { + "AskProgram": "ocaml.ask-debug-program" + } + } ] }, "scripts": { diff --git a/src-bindings/vscode/vscode.ml b/src-bindings/vscode/vscode.ml index 41e6ee47d..69ab8c521 100644 --- a/src-bindings/vscode/vscode.ml +++ b/src-bindings/vscode/vscode.ml @@ -1133,6 +1133,24 @@ module InputBoxOptions = struct [@@js.builder]] end +module OpenDialogOptions = struct + include Interface.Make () + + include + [%js: + val create : + ?canSelectFiles:bool + -> ?canSelectFolders:bool + -> ?canSelectMany:bool + -> ?defaultUri:Uri.t + -> ?filters:string list Interop.Dict.t + -> ?openLabel:string + -> ?title:string + -> unit + -> t + [@@js.builder]] +end + module MessageItem = struct include Interface.Make () @@ -1308,7 +1326,7 @@ module TextDocumentShowOptions = struct val selection : t -> Range.t or_undefined [@@js.get] val create : - viewColumn:ViewColumn.t + ?viewColumn:ViewColumn.t -> ?preserveFocus:bool -> ?preview:bool -> ?selection:Range.t @@ -2978,14 +2996,21 @@ module Window = struct [@@js.get "vscode.window.onDidCloseTerminal"] val showTextDocument : - document: - ([ `TextDocument of TextDocument.t | `Uri of Uri.t ][@js.union]) + document:TextDocument.t -> ?column:ViewColumn.t -> ?preserveFocus:bool -> unit -> TextEditor.t Promise.t [@@js.global "vscode.window.showTextDocument"] + val showTextDocument' : + document: + ([ `TextDocument of TextDocument.t | `Uri of Uri.t ][@js.union]) + -> ?options:TextDocumentShowOptions.t + -> unit + -> TextEditor.t Promise.t + [@@js.global "vscode.window.showTextDocument"] + val showInformationMessage : message:string -> ?options:MessageOptions.t @@ -3033,6 +3058,10 @@ module Window = struct -> string or_undefined Promise.t [@@js.global "vscode.window.showInputBox"] + val showOpenDialog : + ?options:OpenDialogOptions.t -> unit -> Uri.t list or_undefined Promise.t + [@@js.global "vscode.window.showOpenDialog"] + val createOutputChannel : name:string -> OutputChannel.t [@@js.global "vscode.window.createOutputChannel"] @@ -3178,6 +3207,12 @@ module Commands = struct -> Disposable.t [@@js.global "vscode.commands.registerCommand"] + val registerCommandReturn : + command:string + -> callback:(args:(Js.Any.t list[@js.variadic]) -> Js.Any.t) + -> Disposable.t + [@@js.global "vscode.commands.registerCommand"] + val registerTextEditorCommand : command:string -> callback: @@ -3229,3 +3264,176 @@ end module Env = struct include [%js: val shell : unit -> string [@@js.get "vscode.env.shell"]] end + +module DebugAdapterExecutableOptions = struct + include Interface.Make () + + include + [%js: + val cwd : t -> string or_undefined [@@js.get] + + val env : t -> string Dict.t or_undefined [@@js.get] + + val create : ?cwd:string -> ?env:string Dict.t -> unit -> t [@@js.builder]] +end + +module DebugAdapterExecutable = struct + include Class.Make () + + include + [%js: + val make : + command:string + -> ?args:string list + -> ?options:DebugAdapterExecutableOptions.t + -> unit + -> t + [@@js.new "vscode.DebugAdapterExecutable"]] +end + +module DebugAdapterServer = struct + include Class.Make () +end + +module DebugAdapterNamedPipeServer = struct + include Class.Make () +end + +module DebugAdapterInlineImplementation = struct + include Class.Make () +end + +module DebugAdapterDescriptor = struct + type t = + ([ `Executable of DebugAdapterExecutable.t + | `Server of DebugAdapterServer.t + | `NamedPipeServer of DebugAdapterNamedPipeServer.t + | `InlineImplementation of DebugAdapterInlineImplementation.t + ] + [@js.union]) + [@@js] + + let t_of_js js_val : t = + let constructor_name = + [%js.to: string] + @@ Ojs.get_prop_ascii (Ojs.get_prop_ascii js_val "constructor") "name" + in + match constructor_name with + | "DebugAdapterExecutable" -> + `Executable ([%js.to: DebugAdapterExecutable.t] js_val) + | "DebugAdapterServer" -> `Server ([%js.to: DebugAdapterServer.t] js_val) + | "DebugAdapterNamedPipeServer" -> + `NamedPipeServer ([%js.to: DebugAdapterNamedPipeServer.t] js_val) + | "DebugAdapterInlineImplementation" -> + `InlineImplementation + ([%js.to: DebugAdapterInlineImplementation.t] js_val) + | _ -> assert false +end + +module DebugSession = struct + include Class.Make () + + include + [%js: + val customRequest : + t -> command:string -> ?args:Js.Any.t -> unit -> Js.Any.t Promise.t + [@@js.call]] +end + +module DebugAdapterDescriptorFactory = struct + include Interface.Make () + + include + [%js: + val createDebugAdapterDescriptor : + t + -> session:DebugSession.t + -> executable:DebugAdapterExecutable.t or_undefined + -> DebugAdapterDescriptor.t ProviderResult.t + [@@js.call] + + val create : + createDebugAdapterDescriptor: + ( session:DebugSession.t + -> executable:DebugAdapterExecutable.t or_undefined + -> DebugAdapterDescriptor.t ProviderResult.t) + -> t + [@@js.builder]] +end + +module DebugConfiguration = struct + include Interface.Make () + + include + [%js: + val create : name:string -> request:string -> type_:string -> t + [@@js.builder] + + val set : t -> string -> Ojs.t -> unit [@@js.index_set]] +end + +module DebugConfigurationProvider = struct + include Interface.Make () + + include + [%js: + val create : + ?provideDebugConfigurations: + ( folder:WorkspaceFolder.t or_undefined + -> ?token:CancellationToken.t + -> unit + -> DebugConfiguration.t list ProviderResult.t) + -> ?resolveDebugConfiguration: + ( folder:WorkspaceFolder.t or_undefined + -> debugConfiguration:DebugConfiguration.t + -> ?token:CancellationToken.t + -> unit + -> DebugConfiguration.t ProviderResult.t) + -> ?resolveDebugConfigurationWithSubstitutedVariables: + ( folder:WorkspaceFolder.t or_undefined + -> debugConfiguration:DebugConfiguration.t + -> ?token:CancellationToken.t + -> unit + -> DebugConfiguration.t ProviderResult.t) + -> unit + -> t + [@@js.builder]] +end + +module DebugConfigurationProviderTriggerKind = struct + type t = + | Initial [@js 1] [@js.default] + | Dynamic [@js 2] + [@@js.enum] [@@js] +end + +module Debug = struct + include + [%js: + val activeDebugSession : unit -> DebugSession.t or_undefined + [@@js.get "vscode.debug.activeDebugSession"] + + val registerDebugAdapterDescriptorFactory : + debugType:string + -> factory:DebugAdapterDescriptorFactory.t + -> Disposable.t + [@@js.global "vscode.debug.registerDebugAdapterDescriptorFactory"] + + val registerDebugConfigurationProvider : + debugType:string + -> provider:DebugConfigurationProvider.t + -> ?triggerKind:DebugConfigurationProviderTriggerKind.t + -> unit + -> Disposable.t + [@@js.global "vscode.debug.registerDebugConfigurationProvider"] + + val startDebugging : + folder:WorkspaceFolder.t or_undefined + -> nameOrConfiguration: + ([ `Name of string | `Configuration of DebugConfiguration.t ] + [@js.union]) + -> ?parentSessionOrOptions:Ojs.t + -> unit + -> bool Promise.t + [@@js.global "vscode.debug.startDebugging"]] +end diff --git a/src-bindings/vscode/vscode.mli b/src-bindings/vscode/vscode.mli index e35a26cc3..3d713ee0e 100644 --- a/src-bindings/vscode/vscode.mli +++ b/src-bindings/vscode/vscode.mli @@ -896,6 +896,21 @@ module InputBoxOptions : sig -> t end +module OpenDialogOptions : sig + include Js.T + + val create : + ?canSelectFiles:bool + -> ?canSelectFolders:bool + -> ?canSelectMany:bool + -> ?defaultUri:Uri.t + -> ?filters:string list Interop.Dict.t + -> ?openLabel:string + -> ?title:string + -> unit + -> t +end + module MessageItem : sig include Js.T @@ -1015,7 +1030,7 @@ module TextDocumentShowOptions : sig val selection : t -> Range.t option val create : - viewColumn:ViewColumn.t + ?viewColumn:ViewColumn.t -> ?preserveFocus:bool -> ?preview:bool -> ?selection:Range.t @@ -2283,12 +2298,18 @@ module Window : sig val onDidCloseTerminal : unit -> Terminal.t Event.t val showTextDocument : - document:[ `TextDocument of TextDocument.t | `Uri of Uri.t ] + document:TextDocument.t -> ?column:ViewColumn.t -> ?preserveFocus:bool -> unit -> TextEditor.t Promise.t + val showTextDocument' : + document:[ `TextDocument of TextDocument.t | `Uri of Uri.t ] + -> ?options:TextDocumentShowOptions.t + -> unit + -> TextEditor.t Promise.t + val showInformationMessage : message:string -> ?options:MessageOptions.t @@ -2330,6 +2351,9 @@ module Window : sig -> unit -> string option Promise.t + val showOpenDialog : + ?options:OpenDialogOptions.t -> unit -> Uri.t list option Promise.t + val createOutputChannel : name:string -> OutputChannel.t val setStatusBarMessage : @@ -2393,6 +2417,9 @@ module Commands : sig val registerCommand : command:string -> callback:(args:Js.Any.t list -> unit) -> Disposable.t + val registerCommandReturn : + command:string -> callback:(args:Js.Any.t list -> Js.Any.t) -> Disposable.t + val registerTextEditorCommand : command:string -> callback: @@ -2430,3 +2457,135 @@ end module Env : sig val shell : unit -> string end + +module DebugAdapterExecutableOptions : sig + include Js.T + + val cwd : t -> string option + + val env : t -> string Dict.t option + + val create : ?cwd:string -> ?env:string Dict.t -> unit -> t +end + +module DebugAdapterExecutable : sig + include Js.T + + val make : + command:string + -> ?args:string list + -> ?options:DebugAdapterExecutableOptions.t + -> unit + -> t +end + +module DebugAdapterServer : sig + include Js.T +end + +module DebugAdapterNamedPipeServer : sig + include Js.T +end + +module DebugAdapterInlineImplementation : sig + include Js.T +end + +module DebugAdapterDescriptor : sig + type t = + [ `Executable of DebugAdapterExecutable.t + | `Server of DebugAdapterServer.t + | `NamedPipeServer of DebugAdapterNamedPipeServer.t + | `InlineImplementation of DebugAdapterInlineImplementation.t + ] + + include Js.T with type t := t +end + +module DebugSession : sig + include Js.T + + val customRequest : + t -> command:string -> ?args:Js.Any.t -> unit -> Js.Any.t Promise.t +end + +module DebugAdapterDescriptorFactory : sig + include Js.T + + (* TODO: unused? remove? *) + val createDebugAdapterDescriptor : + t + -> session:DebugSession.t + -> executable:DebugAdapterExecutable.t or_undefined + -> DebugAdapterDescriptor.t ProviderResult.t + + val create : + createDebugAdapterDescriptor: + ( session:DebugSession.t + -> executable:DebugAdapterExecutable.t or_undefined + -> DebugAdapterDescriptor.t ProviderResult.t) + -> t +end + +module DebugConfiguration : sig + include Js.T + + val create : name:string -> request:string -> type_:string -> t + + val set : t -> string -> Ojs.t -> unit +end + +module DebugConfigurationProvider : sig + include Js.T + + val create : + ?provideDebugConfigurations: + ( folder:WorkspaceFolder.t or_undefined + -> ?token:CancellationToken.t + -> unit + -> DebugConfiguration.t list ProviderResult.t) + -> ?resolveDebugConfiguration: + ( folder:WorkspaceFolder.t or_undefined + -> debugConfiguration:DebugConfiguration.t + -> ?token:CancellationToken.t + -> unit + -> DebugConfiguration.t ProviderResult.t) + -> ?resolveDebugConfigurationWithSubstitutedVariables: + ( folder:WorkspaceFolder.t or_undefined + -> debugConfiguration:DebugConfiguration.t + -> ?token:CancellationToken.t + -> unit + -> DebugConfiguration.t ProviderResult.t) + -> unit + -> t +end + +module DebugConfigurationProviderTriggerKind : sig + type t = + | Initial + | Dynamic + + include Js.T with type t := t +end + +module Debug : sig + val activeDebugSession : unit -> DebugSession.t option + + val registerDebugAdapterDescriptorFactory : + debugType:string -> factory:DebugAdapterDescriptorFactory.t -> Disposable.t + + val registerDebugConfigurationProvider : + debugType:string + -> provider:DebugConfigurationProvider.t + -> ?triggerKind:DebugConfigurationProviderTriggerKind.t + -> unit + -> Disposable.t + + val startDebugging : + folder:WorkspaceFolder.t or_undefined + -> nameOrConfiguration: + [ `Name of string | `Configuration of DebugConfiguration.t ] + -> ?parentSessionOrOptions:Ojs.t + -> unit + -> bool Promise.t +end diff --git a/src/ast_editor.ml b/src/ast_editor.ml index 534a136e5..c4b4cd386 100644 --- a/src/ast_editor.ml +++ b/src/ast_editor.ml @@ -341,10 +341,7 @@ let open_pp_doc instance ~document = ~pp_doc_uri:(TextDocument.uri doc); replace_document_content ~content:pp_pp_str ~document:doc; let+ (_ : TextEditor.t) = - Window.showTextDocument - ~document:(`TextDocument doc) - ~column:ViewColumn.Beside - () + Window.showTextDocument ~document:doc ~column:ViewColumn.Beside () in Ok () diff --git a/src/cmd.ml b/src/cmd.ml index 18a8d9a36..01d283f5d 100644 --- a/src/cmd.ml +++ b/src/cmd.ml @@ -20,6 +20,13 @@ let to_string = function | Spawn { bin; args } -> Path.to_string bin :: args |> List.map ~f:quote |> String.concat ~sep:" " +let to_spawn = function + | Spawn spawn -> spawn + | Shell command_line -> ( + match Platform.shell with + | Sh bin -> { bin; args = [ "-c"; command_line ] } + | PowerShell bin -> { bin; args = [ "-c"; "& " ^ command_line ] }) + let path_missing_from_env = "'PATH' variable not found in the environment" let append { bin; args = args1 } args2 = { bin; args = args1 @ args2 } diff --git a/src/cmd.mli b/src/cmd.mli index d733454b5..6d487e66d 100644 --- a/src/cmd.mli +++ b/src/cmd.mli @@ -18,6 +18,8 @@ type stderr = string (* surround a string with quotes if it has spaces *) val quote : string -> string +val to_spawn : t -> spawn + val append : spawn -> string list -> spawn val check_spawn : diff --git a/src/earlybird.ml b/src/earlybird.ml new file mode 100644 index 000000000..417ac0880 --- /dev/null +++ b/src/earlybird.ml @@ -0,0 +1,104 @@ +open Import + +module VariableGetClosureCodeLocation = struct + let command = "variableGetClosureCodeLocation" + + module Args = struct + type t = { handle : int } [@@js] + end + + module Result = struct + type position = int * int [@@js] + + let position_to_vscode (line, character) = + Position.make ~line:(line - 1) ~character:(character - 1) + + type range = + { source : string + ; pos : position + ; end_ : position [@js "end_"] + } + [@@js] + + let range_to_vscode { pos; end_; _ } = + let start = position_to_vscode pos in + let end_ = position_to_vscode end_ in + Range.makePositions ~start ~end_ + + type t = { location : range option } [@@js] + end +end + +let debugType = Extension_consts.Debuggers.earlybird + +let check_earlybird_available sandbox = + let earlybird_help = + (* earlybird <= 1.1.0 doesn't have --version *) + Sandbox.get_command sandbox "ocamlearlybird" [ "--help" ] + in + Cmd.output earlybird_help + |> Promise.Result.fold + ~ok:(fun (_ : string) -> ()) + ~error:(fun (_ : string) -> + "Debugging failed: `earlybird` is not installed in the current \ + sandbox.\n\n\ + Hint: $ opam install earlybird") + +let createDebugAdapterDescriptor ~instance ~session:_ ~executable:_ = + let sandbox = Extension_instance.sandbox instance in + let promise = + let open Promise.Syntax in + let* res = check_earlybird_available sandbox in + match res with + | Ok () -> + let command = Sandbox.get_command sandbox "ocamlearlybird" [ "debug" ] in + let { Cmd.bin; args } = Cmd.to_spawn command in + let result = + DebugAdapterExecutable.make ~command:(Path.to_string bin) ~args () + in + Promise.return (Some (`Executable result)) + | Error s -> Promise.reject (Ojs.string_to_js s) + in + `Promise promise + +let register extension instance = + let createDebugAdapterDescriptor = createDebugAdapterDescriptor ~instance in + let factory = + DebugAdapterDescriptorFactory.create ~createDebugAdapterDescriptor + in + let disposable = + Debug.registerDebugAdapterDescriptorFactory ~debugType ~factory + in + ExtensionContext.subscribe extension ~disposable; + + let callback ~args:_ = + let open Promise.Syntax in + let defaultUri = + Option.map (Workspace.rootPath ()) ~f:(fun path -> Uri.parse path ()) + in + let filters = Interop.Dict.singleton "OCaml Bytecode Executable" [ "bc" ] in + let options = + OpenDialogOptions.create + ~canSelectFiles:true + ~canSelectFolders:false + ~canSelectMany:false + ?defaultUri + ~filters + ~openLabel:"Debug" + ~title:"OCaml earlybird (experimental)" + () + in + let result = + let+ uri = Window.showOpenDialog ~options () in + match uri with + | Some [ uri ] -> Some (Uri.fsPath uri) + | _ -> None + in + [%js.of: string option Promise.t] result + in + let disposable = + Commands.registerCommandReturn + ~command:Extension_consts.Commands.ask_debug_program + ~callback + in + ExtensionContext.subscribe extension ~disposable diff --git a/src/earlybird.mli b/src/earlybird.mli new file mode 100644 index 000000000..4da2ad3dc --- /dev/null +++ b/src/earlybird.mli @@ -0,0 +1,27 @@ +module VariableGetClosureCodeLocation : sig + val command : string + + module Args : sig + type t = { handle : int } + + val t_to_js : t -> Ojs.t + end + + module Result : sig + type position + + type range = + { source : string + ; pos : position + ; end_ : position + } + + val range_to_vscode : range -> Vscode.Range.t + + type t = { location : range option } + + val t_of_js : Ojs.t -> t + end +end + +val register : Vscode.ExtensionContext.t -> Extension_instance.t -> unit diff --git a/src/extension_commands.ml b/src/extension_commands.ml index eda0ea518..20b991fb9 100644 --- a/src/extension_commands.ml +++ b/src/extension_commands.ml @@ -370,6 +370,104 @@ end = struct command Extension_consts.Commands.prev_hole (jump_to_hole Prev_hole.jump) end +module Debug_commands : sig + val _goto_closure_code_location : t + + val _start_debugging : t +end = struct + let _start_debugging = + let handler (_ : Extension_instance.t) ~args = + let resourceUri = + match args with + | resourceUri :: _ -> Some (Uri.t_of_js resourceUri) + | [] -> + Option.map (Window.activeTextEditor ()) ~f:(fun textEditor -> + TextDocument.uri (TextEditor.document textEditor)) + in + match resourceUri with + | Some uri -> + let folder = Workspace.getWorkspaceFolder ~uri in + let fsPath = Uri.fsPath uri in + let name = Path.basename (Path.of_string fsPath) ^ " (experimental)" in + let config = + DebugConfiguration.create + ~name + ~type_:Extension_consts.Debuggers.earlybird + ~request:"launch" + in + DebugConfiguration.set config "program" (Ojs.string_to_js fsPath); + DebugConfiguration.set config "stopOnEntry" (Ojs.bool_to_js true); + let (_ : bool Promise.t) = + Debug.startDebugging + ~folder + ~nameOrConfiguration:(`Configuration config) + () + in + () + | None -> + let _ = Window.showErrorMessage ~message:"No active resource" () in + () + in + command Extension_consts.Commands.start_debugging handler + + let _goto_closure_code_location = + let handler (_ : Extension_instance.t) ~args = + let open Promise.Syntax in + match Debug.activeDebugSession () with + | Some debugSession -> + let context = List.hd_exn args in + let variablesReference = + Jsonoo.Decode.( + at [ "variable"; "variablesReference" ] int (Jsonoo.t_of_js context)) + in + let args = + Earlybird.VariableGetClosureCodeLocation.Args.t_to_js + { handle = variablesReference } + in + let (_ : unit Promise.t) = + let* result = + DebugSession.customRequest + debugSession + ~command:Earlybird.VariableGetClosureCodeLocation.command + ~args + () + in + let result = + Earlybird.VariableGetClosureCodeLocation.Result.t_of_js result + in + match result.location with + | Some range -> + let* text_document = + Workspace.openTextDocument (`Filename range.source) + in + let selection = + Earlybird.VariableGetClosureCodeLocation.Result.range_to_vscode + range + in + let+ _ = + Window.showTextDocument' + ~document:(`TextDocument text_document) + ~options: + (TextDocumentShowOptions.create ~preview:true ~selection ()) + () + in + () + | None -> + let+ _ = + Window.showInformationMessage + ~message:"No closure code location" + () + in + () + in + () + | None -> + let _ = Window.showErrorMessage ~message:"No active debug session" () in + () + in + command Extension_consts.Commands.goto_closure_code_location handler +end + let register extension instance = function | Command { id; handler } -> let callback = handler instance in diff --git a/src/extension_consts.ml b/src/extension_consts.ml index a1a1341d7..21e35e831 100644 --- a/src/extension_consts.ml +++ b/src/extension_consts.ml @@ -60,6 +60,12 @@ module Commands = struct ocaml_prefixed "open-ocaml-platform-ext-output" let open_ocaml_commands_output = ocaml_prefixed "open-ocaml-commands-output" + + let start_debugging = ocaml_prefixed "start-debugging" + + let goto_closure_code_location = ocaml_prefixed "goto-closure-code-location" + + let ask_debug_program = ocaml_prefixed "ask-debug-program" end module Command_errors = struct @@ -71,4 +77,8 @@ module Command_errors = struct expl end +module Debuggers = struct + let earlybird = ocaml_prefixed "earlybird" +end + (* TODO: Refactor the code so that we don't need any "constants" module *) diff --git a/src/import.ml b/src/import.ml index 03e5a0095..0976f3f6d 100644 --- a/src/import.ml +++ b/src/import.ml @@ -104,7 +104,7 @@ let log_value msg (js_val : Ojs.t) = log_json msg (Jsonoo.t_of_js js_val) let open_file_in_text_editor target_uri = let open Promise.Syntax in let uri = Uri.parse target_uri () in - let* doc = + let* document = Workspace.openTextDocument (`Uri uri) |> Promise.catch ~rejected:(fun (_ : Promise.error) -> (* if file does not exist *) @@ -112,7 +112,7 @@ let open_file_in_text_editor target_uri = let+ doc = Workspace.openTextDocument (`Uri create_file_uri) in doc) in - let+ text_editor = Window.showTextDocument ~document:(`TextDocument doc) () in + let+ text_editor = Window.showTextDocument ~document () in text_editor let with_confirmation message ~yes ?(no = "Cancel") f = diff --git a/src/terminal_sandbox.ml b/src/terminal_sandbox.ml index 2ede7aaf5..2f3ca0722 100644 --- a/src/terminal_sandbox.ml +++ b/src/terminal_sandbox.ml @@ -70,18 +70,14 @@ let get_shell_args () = type t = Terminal.t let create ?name ?command sandbox = - let shell_path = get_shell_path () in - let shell_args = get_shell_args () in let ({ Cmd.bin; args } as command) = match command with | Some command -> command - | None -> ( - match Sandbox.get_command sandbox shell_path shell_args with - | Spawn spawn -> spawn - | Shell command_line -> ( - match Platform.shell with - | Sh bin -> { bin; args = [ "-c"; command_line ] } - | PowerShell bin -> { bin; args = [ "-c"; "& " ^ command_line ] })) + | None -> + let shell_path = get_shell_path () in + let shell_args = get_shell_args () in + let command = Sandbox.get_command sandbox shell_path shell_args in + Cmd.to_spawn command in Cmd.log (Spawn command); let name = Option.value name ~default:(Sandbox.to_pretty_string sandbox) in diff --git a/src/vscode_ocaml_platform.ml b/src/vscode_ocaml_platform.ml index ce369b16f..6858a9aaf 100644 --- a/src/vscode_ocaml_platform.ml +++ b/src/vscode_ocaml_platform.ml @@ -36,6 +36,7 @@ let activate (extension : ExtensionContext.t) = Ast_editor.register extension instance; Cm_editor.register extension instance; Repl.register extension instance; + Earlybird.register extension instance; let sandbox_opt = Sandbox.of_settings_or_detect () in let (_ : unit Promise.t) = let* sandbox_opt in