diff --git a/assets/run-dark.svg b/assets/run-dark.svg new file mode 100644 index 000000000..8b0a58eca --- /dev/null +++ b/assets/run-dark.svg @@ -0,0 +1,3 @@ + + + diff --git a/assets/run-light.svg b/assets/run-light.svg new file mode 100644 index 000000000..6d670de27 --- /dev/null +++ b/assets/run-light.svg @@ -0,0 +1,3 @@ + + + diff --git a/package.json b/package.json index eb7f00269..9c351ff4b 100644 --- a/package.json +++ b/package.json @@ -325,6 +325,20 @@ "command": "ocaml.install-dune-lsp", "category": "OCaml", "title": "Start the Ocaml-LSP server for Dune Package Management" + }, + { + "command": "ocaml.view-metrics", + "category": "OCaml", + "title": "View metrics" + }, + { + "command": "ocaml.run-standalone-file", + "category": "OCaml", + "title": "Run as a standalone bytecode executable", + "icon": { + "light": "assets/run-light.svg", + "dark": "assets/run-dark.svg" + } } ], "configuration": { @@ -563,6 +577,58 @@ } ], "debuggers": [ + { + "type": "ocaml.run-standalone-file", + "label": "Run standalone OCaml file", + "configurationAttributes": { + "launch": { + "required": [ + "program" + ], + "properties": { + "cwd": { + "type": "string", + "description": "The working directory for runned program." + }, + "program": { + "type": "string", + "description": "The path of runned program." + }, + "arguments": { + "type": "array", + "items": { + "type": "string" + }, + "description": "The command-line arguments for runned program.", + "default": [] + } + } + } + }, + "initialConfigurations": [ + { + "name": "Run standalone OCaml file", + "type": "ocaml.run-standalone-file", + "request": "launch", + "program": "${command:AskProgram}" + } + ], + "configurationSnippets": [ + { + "label": "OCaml: Run standalone file", + "description": "Configuration for running OCaml program", + "body": { + "name": "${2: Launch program}", + "type": "ocaml.run-standalone-file", + "request": "launch", + "program": "^\"\\${workspaceFolder}/${1:OCaml standalone file}\"" + } + } + ], + "variables": { + "AskProgram": "ocaml.ask-run-program" + } + }, { "type": "ocaml.earlybird", "label": "OCaml earlybird (experimental)", @@ -1179,6 +1245,10 @@ "command": "ocaml.goto-closure-code-location", "when": "false" }, + { + "command": "ocaml.start-run", + "when": "false" + }, { "command": "ocaml.copy-type-under-cursor", "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason" @@ -1202,6 +1272,11 @@ "key": "Alt+O", "when": "editorTextFocus && (editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == ocaml.mlx || editorLangId == reason)", "group": "navigation" + }, + { + "command": "ocaml.run-standalone-file", + "when": "editorTextFocus && editorLangId == ocaml", + "group": "navigation" } ], "view/title": [ @@ -1461,7 +1536,9 @@ }, "activationEvents": [ "onCommand:ocaml.ask-debug-program", + "onCommand:ocaml.ask-run-program", "onDebugResolve:ocaml.earlybird", + "onDebugResolve:ocaml.run-standalone-file", "onLanguage:cram", "workspaceContains:**/*.ml", "workspaceContains:**/*.mli", diff --git a/src-bindings/vscode/vscode.ml b/src-bindings/vscode/vscode.ml index df343077d..7ff56ed09 100644 --- a/src-bindings/vscode/vscode.ml +++ b/src-bindings/vscode/vscode.ml @@ -3352,13 +3352,24 @@ module DebugAdapterDescriptor = struct ;; 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 DebugSession = struct include Class.Make () include [%js: val customRequest : t -> command:string -> ?args:Ojs.t -> unit -> Ojs.t Promise.t - [@@js.call]] + [@@js.call] + + val configuration : t -> DebugConfiguration.t [@@js.get]] end module DebugAdapterDescriptorFactory = struct @@ -3382,15 +3393,6 @@ module DebugAdapterDescriptorFactory = struct [@@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 () diff --git a/src-bindings/vscode/vscode.mli b/src-bindings/vscode/vscode.mli index aa78fbccb..628bb58bc 100644 --- a/src-bindings/vscode/vscode.mli +++ b/src-bindings/vscode/vscode.mli @@ -2383,10 +2383,18 @@ module DebugAdapterDescriptor : sig include Ojs.T with type t := t end +module DebugConfiguration : sig + include Ojs.T + + val create : name:string -> request:string -> type_:string -> t + val set : t -> string -> Ojs.t -> unit +end + module DebugSession : sig include Ojs.T val customRequest : t -> command:string -> ?args:Ojs.t -> unit -> Ojs.t Promise.t + val configuration : t -> DebugConfiguration.t end module DebugAdapterDescriptorFactory : sig @@ -2407,13 +2415,6 @@ module DebugAdapterDescriptorFactory : sig -> t end -module DebugConfiguration : sig - include Ojs.T - - val create : name:string -> request:string -> type_:string -> t - val set : t -> string -> Ojs.t -> unit -end - module DebugConfigurationProvider : sig include Ojs.T diff --git a/src/cmd.ml b/src/cmd.ml index 4e07f9b59..ffdbe1fa8 100644 --- a/src/cmd.ml +++ b/src/cmd.ml @@ -78,10 +78,10 @@ let check ?env t = Spawn s ;; -let run ?cwd ?env ?stdin cmd = +let run ?output ?cwd ?env ?stdin cmd = let cwd = Option.map cwd ~f:Path.to_string in let logger event = - let (lazy output) = Output.command_output_channel in + let (lazy output) = Option.value output ~default:Output.command_output_channel in match event with | ChildProcess.Spawned -> Vscode.OutputChannel.appendLine output ~value:("$ " ^ to_string cmd) diff --git a/src/cmd.mli b/src/cmd.mli index 6458d0fbd..1d8883ff3 100644 --- a/src/cmd.mli +++ b/src/cmd.mli @@ -32,7 +32,8 @@ val output val equal_spawn : spawn -> spawn -> bool val run - : ?cwd:Path.t + : ?output:OutputChannel.t Lazy.t + -> ?cwd:Path.t -> ?env:string Interop.Dict.t -> ?stdin:stderr -> t diff --git a/src/command_api.ml b/src/command_api.ml index 964c8a0a9..a3b163e3d 100644 --- a/src/command_api.ml +++ b/src/command_api.ml @@ -140,6 +140,18 @@ module Internal = struct ~return_type:(module Return) ;; + let ask_run_program = + let module Return = struct + type t = string option Promise.t [@@js] + end + in + typed_handle + "ask-run-program" + ~args_of_js:(Fn.const ()) + ~args_to_js:(Fn.const []) + ~return_type:(module Return) + ;; + let copy_type_under_cursor = unit_handle "copy-type-under-cursor" let construct = unit_handle "construct" let merlin_jump = unit_handle "jump" @@ -154,6 +166,7 @@ module Internal = struct let init_opam = unit_handle "init-opam" let install_ocaml_dev = unit_handle "install-ocaml-dev" let open_utop = unit_handle "open-utop" + let run_standalone_file = unit_handle "run-standalone-file" end module Vscode = struct diff --git a/src/command_api.mli b/src/command_api.mli index 039d312de..ad9256951 100644 --- a/src/command_api.mli +++ b/src/command_api.mli @@ -41,6 +41,7 @@ module Internal : sig val start_debugging : (Vscode.Uri.t option, unit) handle val goto_closure_code_location : (Jsonoo.t, unit) handle val ask_debug_program : (unit, string option Promise.t) handle + val ask_run_program : (unit, string option Promise.t) handle val copy_type_under_cursor : (unit, unit) handle val construct : (unit, unit) handle val merlin_jump : (unit, unit) handle @@ -55,6 +56,7 @@ module Internal : sig val init_opam : (unit, unit) handle val install_ocaml_dev : (unit, unit) handle val open_utop : (unit, unit) handle + val run_standalone_file : (unit, unit) handle end module Vscode : sig diff --git a/src/output.ml b/src/output.ml index 90d16f0ba..b4a124a47 100644 --- a/src/output.ml +++ b/src/output.ml @@ -14,3 +14,5 @@ let extension_output_channel = let command_output_channel = lazy (Vscode.Window.createOutputChannel ~name:"OCaml Commands" ()) ;; + +let run_output_channel = lazy (Vscode.Window.createOutputChannel ~name:"Run OCaml" ()) diff --git a/src/output.mli b/src/output.mli index 854e8a07c..35a99138a 100644 --- a/src/output.mli +++ b/src/output.mli @@ -9,3 +9,5 @@ val extension_output_channel : Vscode.OutputChannel.t Lazy.t (** [command_output_channel] is the output channel for user-friendly logs of shell commands *) val command_output_channel : Vscode.OutputChannel.t Lazy.t + +val run_output_channel : Vscode.OutputChannel.t Lazy.t diff --git a/src/standalone_file.ml b/src/standalone_file.ml new file mode 100644 index 000000000..5d9950241 --- /dev/null +++ b/src/standalone_file.ml @@ -0,0 +1,170 @@ +open Import + +let active_document_uri () = + match Window.activeTextEditor () with + | None -> + Error + (Command_api.Command_errors.text_editor_must_be_active + "Run standalone file" + ~expl:"") + | Some text_editor -> + let document = TextEditor.document text_editor in + if String.(TextDocument.languageId document = "ocaml") + then ( + let abs_path = TextDocument.uri document |> Uri.path in + match Workspace.rootPath () with + | None -> Ok abs_path + | Some root -> + (match String.chop_prefix ~prefix:root abs_path with + | None -> Ok abs_path + | Some rel_path -> Ok ("." ^ rel_path))) + else + Error "The command \"OCaml: Run standalone file\" should be run only on OCaml file." +;; + +let inside_dune_project () = + Workspace.findFiles + ~includes:(`String "**/{dune-project}") + ~excludes:(`String "{**/_*}" (* ignoring dune files from _build, _opam, _esy *)) + () + |> Promise.map (function + | [ _ ] -> true + | _ -> false) +;; + +let run_dune_exec_command sandbox = + active_document_uri () + |> Result.map ~f:(fun filename -> + let filename = Stdlib.Filename.remove_extension filename ^ ".exe" in + Sandbox.get_command sandbox "dune" [ "exec"; filename ] `Exec) +;; + +let run_program_command ~sandbox ?(args = []) program = + Sandbox.get_command + sandbox + "ocaml" + ([ "-I"; "+str"; "-I"; "+unix"; program ] @ args) + `Exec +;; + +let exec instance = + match active_document_uri () with + | Ok program -> + let open Promise.Syntax in + let sandbox = Extension_instance.sandbox instance in + OutputChannel.show ~preserveFocus:true (Lazy.force Output.run_output_channel) (); + let* dune_context = inside_dune_project () in + (match + if dune_context + then run_dune_exec_command sandbox + else Ok (run_program_command ~sandbox program) + with + | Ok cmd -> + let* command = Cmd.check cmd in + (match command with + | Ok cmd -> + let+ _ = + Cmd.run ?cwd:(Sandbox.workspace_root ()) ~output:Output.run_output_channel cmd + in + Ok () + | Error _ as err -> Promise.return err) + | Error _ as err -> Promise.return err) + | Error _ as err -> Promise.return err +;; + +let _run_standalone_file = + let callback (instance : Extension_instance.t) () = + let open Promise.Syntax in + let (_ : unit Promise.t) = + let+ result = exec instance in + Result.iter_error result ~f:(fun msg -> show_message `Error "%s" msg) + in + () + in + Extension_commands.register Command_api.Internal.run_standalone_file callback +;; + +let _ask_run_program = + let callback (_ : Extension_instance.t) () = + let open Promise.Syntax in + let defaultUri = + Workspace.rootPath () |> Option.map ~f:(fun path -> Uri.parse path ()) + in + let options = + OpenDialogOptions.create + ~canSelectFiles:true + ~canSelectFolders:false + ~canSelectMany:false + ?defaultUri + ~filters:(Interop.Dict.singleton "OCaml file" [ "ml" ]) + ~openLabel:"Debug" + ~title:"Run OCaml standalone file" + () + in + let+ uri = Window.showOpenDialog ~options () in + match uri with + | Some [ uri ] -> Some (Uri.fsPath uri) + | _ -> None + in + Extension_commands.register Command_api.Internal.ask_run_program callback +;; + +let debugType = "ocaml.run-standalone-file" + +let register_provider () = + let provider = + DebugConfigurationProvider.create + ~resolveDebugConfiguration:(fun ~folder:_ ~debugConfiguration ?token:_ () -> + let config = DebugConfiguration.t_to_js debugConfiguration in + if not (Ojs.has_property config "program") + then ( + match active_document_uri () with + | Ok filename -> + DebugConfiguration.set debugConfiguration "program" + @@ [%js.of: string] filename + | Error msg -> show_message `Error "%s" msg); + `Value (Some debugConfiguration)) + () + in + Debug.registerDebugConfigurationProvider ~debugType ~provider () +;; + +let debug_executable_from_session ~instance ~session () = + let config = DebugSession.configuration session |> DebugConfiguration.t_to_js in + let program = [%js.to: string] (Ojs.get_prop_ascii config "program") + and cwd = [%js.to: string] (Ojs.get_prop_ascii config "cwd") + and args = [%js.to: string list] (Ojs.get_prop_ascii config "args") in + let open Promise.Syntax in + let sandbox = Extension_instance.sandbox instance in + let+ command = run_program_command ~sandbox program ~args |> Cmd.check in + match command with + | Ok cmd -> + let { Cmd.bin; args } = Cmd.to_spawn cmd in + let options = DebugAdapterExecutableOptions.create ~cwd () in + let adaptater = + DebugAdapterExecutable.make ~command:(Path.to_string bin) ~args ~options () + in + Some (`Executable adaptater) + | Error _ -> None +;; + +let register_debug_adapter_descr ~instance = + let factory = + DebugAdapterDescriptorFactory.create + ~createDebugAdapterDescriptor:(fun ~session ~executable:_ -> + `Promise (debug_executable_from_session ~instance ~session ())) + in + Debug.registerDebugAdapterDescriptorFactory ~debugType ~factory +;; + +let register extension instance = + let dispose_channel = + Disposable.make ~dispose:(fun () -> + Lazy.peek Output.run_output_channel |> Option.iter ~f:OutputChannel.dispose) + and dispose_provider = register_provider () + and dispose_debug_adapter = register_debug_adapter_descr ~instance in + ExtensionContext.subscribe + extension + ~disposable: + (Disposable.from [ dispose_channel; dispose_debug_adapter; dispose_provider ]) +;; diff --git a/src/standalone_file.mli b/src/standalone_file.mli new file mode 100644 index 000000000..8cbb1435f --- /dev/null +++ b/src/standalone_file.mli @@ -0,0 +1 @@ +val register : Vscode.ExtensionContext.t -> Extension_instance.t -> unit diff --git a/src/vscode_ocaml_platform.ml b/src/vscode_ocaml_platform.ml index 7cb6c5bb0..e295dc4e1 100644 --- a/src/vscode_ocaml_platform.ml +++ b/src/vscode_ocaml_platform.ml @@ -39,6 +39,7 @@ let activate (extension : ExtensionContext.t) = Ast_editor.register extension instance; Cm_editor.register extension instance; Repl.register extension instance; + Standalone_file.register extension instance; Earlybird.register extension instance; (* Extension_commands.register_all_commands registers all commands that were added in the register functions above. It must be called last. *)