From 95cdd9f5d40bc9cf4411cb1c9a73c75bccd5261a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 23 Oct 2024 16:54:59 +0200 Subject: [PATCH 1/2] Handle type of dynamic selection. New commands allow showing the type of the current selection, and grow / shrink that selection. Another commands increases the verbosity on demand. --- package.json | 40 +++++ src-bindings/vscode/vscode.ml | 83 ++++++++- src-bindings/vscode/vscode.mli | 65 ++++++- src/ast_editor.ml | 30 +--- src/custom_requests.ml | 6 +- src/custom_requests.mli | 4 +- src/extension_commands.ml | 19 +- src/extension_consts.ml | 3 + src/extension_instance.ml | 39 ++++- src/extension_instance.mli | 10 +- src/import.ml | 28 +++ src/ocaml_lsp.ml | 15 +- src/ocaml_lsp.mli | 4 +- src/output.ml | 6 +- src/type_selection.ml | 307 +++++++++++++++++++++++++++++++++ src/vscode_ocaml_platform.ml | 3 +- 16 files changed, 597 insertions(+), 65 deletions(-) create mode 100644 src/type_selection.ml diff --git a/package.json b/package.json index 6bb159d3a..a4de1b976 100644 --- a/package.json +++ b/package.json @@ -272,6 +272,21 @@ "command": "ocaml.navigate-typed-holes", "category": "OCaml", "title": "List typed holes in the file for navigation" + }, + { + "command": "ocaml.type-selection", + "category": "OCaml", + "title": "Get the type of the selection" + }, + { + "command": "ocaml.type-previous-selection", + "category": "OCaml", + "title": "Show previous type-selection steps." + }, + { + "command": "ocaml.augment-selection-type-verbosity", + "category": "OCaml", + "title": "Increase the verbosity of the selection's type." } ], "configuration": { @@ -311,6 +326,16 @@ "default": true, "markdownDescription": "Enable/Disable dune diagnostics" }, + "ocaml.commands.typeSelection.outputChannelResults": { + "type": "boolean", + "default": true, + "markdownDescription": "Enable/Disable type of selection results to appear in a dedicated output channel in the side panel." + }, + "ocaml.commands.typeSelection.alwaysClearOutputChannel": { + "type": "boolean", + "default": false, + "markdownDescription": "Enable/Disable clearing of the output channel before showing a new result." + }, "ocaml.server.syntaxDocumentation": { "type": "boolean", "default": false, @@ -796,6 +821,21 @@ "command": "ocaml.search-by-type", "key": "Alt+F", "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason || editorLangId == ocaml.ocamllex" + }, + { + "command": "ocaml.type-selection", + "key": "Alt+T", + "when": "editorTextFocus && editorLangId == ocaml || editorLangId == ocaml.interface" + }, + { + "command": "ocaml.type-previous-selection", + "key": "Shift+Alt+T", + "when": "editorTextFocus && editorLangId == ocaml || editorLangId == ocaml.interface" + }, + { + "command": "ocaml.augment-selection-type-verbosity", + "key": "Alt+V", + "when": "editorTextFocus && editorLangId == ocaml || editorLangId == ocaml.interface" } ], "languages": [ diff --git a/src-bindings/vscode/vscode.ml b/src-bindings/vscode/vscode.ml index 1d79dbdce..0e6334773 100644 --- a/src-bindings/vscode/vscode.ml +++ b/src-bindings/vscode/vscode.ml @@ -530,6 +530,41 @@ module ThemableDecorationAttachmentRenderOptions = struct [@@js.builder]] end +module DecorationRenderOptions = struct + include Interface.Make () + + type color = ThemableDecorationAttachmentRenderOptions.color [@@js] + + include + [%js: + val create + : ?backgroundColor:color + -> ?outline:string + -> ?outlineColor:color + -> ?outlineStyle:string + -> ?outlineWidth:string + -> ?border:string + -> ?borderColor:color + -> ?borderRadius:string + -> ?borderSpacing:string + -> ?borderStyle:string + -> ?borderWidth:string + -> ?fontStyle:string + -> ?fontWeight:string + -> ?textDecoration:string + -> ?cursor:string + -> ?color:color + -> ?opacity:string + -> ?letterSpacing:string + -> ?overviewRulerColor:color + -> ?before:ThemableDecorationAttachmentRenderOptions.t + -> ?after:ThemableDecorationAttachmentRenderOptions.t + -> ?isWholeLine:bool + -> unit + -> t + [@@js.builder]] +end + module ThemableDecorationInstanceRenderOptions = struct include Interface.Make () @@ -693,6 +728,31 @@ module TextEditor = struct ;; end +module TextEditorSelectionChangeKind = struct + type t = + | Keyboard [@js 1] + | Mouse [@js 2] + | Command [@js 3] + [@@js.enum] [@@js] +end + +module TextEditorSelectionChangeEvent = struct + include Interface.Make () + + include + [%js: + val textEditor : t -> TextEditor.t [@@js.get] + val selections : t -> Selection.t list [@@js.get] + val kind : t -> TextEditorSelectionChangeKind.t [@@js.get] + + val create + : textEditor:TextEditor.t + -> selections:Selection.t list + -> kind:TextEditorSelectionChangeKind.t + -> t + [@@js.builder]] +end + module ConfigurationTarget = struct type t = | Global [@js 1] @@ -1578,6 +1638,7 @@ module OutputChannel = struct val name : t -> string [@@js.get] val append : t -> value:string -> unit [@@js.call] val appendLine : t -> value:string -> unit [@@js.call] + val replace : t -> value:string -> unit [@@js.call] val clear : t -> unit [@@js.call] val show : t -> ?preserveFocus:bool -> unit -> unit [@@js.call] val hide : t -> unit [@@js.call] @@ -1988,6 +2049,8 @@ module Hover = struct | `MarkdownStringArray of MarkdownString.t list ] [@js.union]) + -> ?range:Range.t + -> unit -> t [@@js.new "vscode.Hover"]] end @@ -2902,6 +2965,11 @@ module Window = struct val onDidChangeVisibleTextEditors : unit -> TextEditor.t list Event.t [@@js.get "vscode.window.onDidChangeVisibleTextEditors"] + val onDidChangeTextEditorSelection + : unit + -> TextEditorSelectionChangeEvent.t Event.t + [@@js.get "vscode.window.onDidChangeTextEditorSelection"] + val terminals : unit -> Terminal.t list [@@js.get "vscode.window.terminals"] val activeTerminal : unit -> Terminal.t or_undefined @@ -2931,6 +2999,11 @@ module Window = struct -> TextEditor.t Promise.t [@@js.global "vscode.window.showTextDocument"] + val createTextEditorDecorationType + : options:DecorationRenderOptions.t + -> TextEditorDecorationType.t + [@@js.global "vscode.window.createTextEditorDecorationType"] + val showInformationMessage : message:string -> ?options:MessageOptions.t @@ -2987,6 +3060,13 @@ module Window = struct -> string or_undefined Promise.t [@@js.global "vscode.window.showInputBox"] + val createOutputChannel + : name:string + -> ?languageId:string + -> unit + -> OutputChannel.t + [@@js.global "vscode.window.createOutputChannel"] + val createInputBox : unit -> InputBox.t [@@js.global "vscode.window.createInputBox"] val showOpenDialog @@ -2995,9 +3075,6 @@ module Window = struct -> Uri.t list or_undefined Promise.t [@@js.global "vscode.window.showOpenDialog"] - val createOutputChannel : name:string -> OutputChannel.t - [@@js.global "vscode.window.createOutputChannel"] - val setStatusBarMessage : text:string -> ?hide:([ `AfterTimeout of int ][@js.union]) diff --git a/src-bindings/vscode/vscode.mli b/src-bindings/vscode/vscode.mli index 514e8664b..d00f95e86 100644 --- a/src-bindings/vscode/vscode.mli +++ b/src-bindings/vscode/vscode.mli @@ -399,6 +399,38 @@ module ThemableDecorationAttachmentRenderOptions : sig -> t end +module DecorationRenderOptions : sig + include Ojs.T + + type color = ThemableDecorationAttachmentRenderOptions.color + + val create + : ?backgroundColor:color + -> ?outline:string + -> ?outlineColor:color + -> ?outlineStyle:string + -> ?outlineWidth:string + -> ?border:string + -> ?borderColor:color + -> ?borderRadius:string + -> ?borderSpacing:string + -> ?borderStyle:string + -> ?borderWidth:string + -> ?fontStyle:string + -> ?fontWeight:string + -> ?textDecoration:string + -> ?cursor:string + -> ?color:color + -> ?opacity:string + -> ?letterSpacing:string + -> ?overviewRulerColor:color + -> ?before:ThemableDecorationAttachmentRenderOptions.t + -> ?after:ThemableDecorationAttachmentRenderOptions.t + -> ?isWholeLine:bool + -> unit + -> t +end + module ThemableDecorationInstanceRenderOptions : sig include Ojs.T @@ -518,6 +550,29 @@ module TextEditor : sig -> unit end +module TextEditorSelectionChangeKind : sig + type t = + | Keyboard + | Mouse + | Command + + include Ojs.T with type t := t +end + +module TextEditorSelectionChangeEvent : sig + include Ojs.T + + val textEditor : t -> TextEditor.t + val selections : t -> Selection.t list + val kind : t -> TextEditorSelectionChangeKind.t + + val create + : textEditor:TextEditor.t + -> selections:Selection.t list + -> kind:TextEditorSelectionChangeKind.t + -> t +end + module ConfigurationTarget : sig type t = | Global @@ -1136,6 +1191,7 @@ module OutputChannel : sig val name : t -> string val append : t -> value:string -> unit val appendLine : t -> value:string -> unit + val replace : t -> value:string -> unit val clear : t -> unit val show : t -> ?preserveFocus:bool -> unit -> unit val hide : t -> unit @@ -1426,6 +1482,8 @@ module Hover : sig [ `MarkdownString of MarkdownString.t | `MarkdownStringArray of MarkdownString.t list ] + -> ?range:Range.t + -> unit -> t end @@ -2083,6 +2141,7 @@ module Window : sig val visibleTextEditors : unit -> TextEditor.t list val onDidChangeActiveTextEditor : unit -> TextEditor.t Event.t val onDidChangeVisibleTextEditors : unit -> TextEditor.t list Event.t + val onDidChangeTextEditorSelection : unit -> TextEditorSelectionChangeEvent.t Event.t val terminals : unit -> Terminal.t List.t val activeTerminal : unit -> Terminal.t option val onDidChangeActiveTerminal : unit -> Terminal.t option Event.t @@ -2102,6 +2161,10 @@ module Window : sig -> unit -> TextEditor.t Promise.t + val createTextEditorDecorationType + : options:DecorationRenderOptions.t + -> TextEditorDecorationType.t + val showInformationMessage : message:string -> ?options:MessageOptions.t @@ -2148,7 +2211,7 @@ module Window : sig val createInputBox : unit -> InputBox.t val showOpenDialog : ?options:OpenDialogOptions.t -> unit -> Uri.t list option Promise.t - val createOutputChannel : name:string -> OutputChannel.t + val createOutputChannel : name:string -> ?languageId:string -> unit -> OutputChannel.t val setStatusBarMessage : text:string diff --git a/src/ast_editor.ml b/src/ast_editor.ml index 0174ced15..78cbb7e5b 100644 --- a/src/ast_editor.ml +++ b/src/ast_editor.ml @@ -1,33 +1,5 @@ open Import -exception User_error of string - -module Handlers = struct - let unpwrap = function - | `Ok () -> () - | `Error err_msg -> show_message `Error "%s" err_msg - ;; - - let w1 f x = - try `Ok (f x) with - | User_error e -> `Error e - ;; - - let ws f x y = - match f x with - | `Ok f' -> - (try `Ok (f' y) with - | User_error e -> `Error e) - | `Error e -> `Error e - ;; - - let w2 f = ws (w1 f) - let w3 f x = ws (w2 f x) - let w4 f x y = ws (w3 f x y) - let w5 f x y z = ws (w4 f x y z) - let _w6 f x y z w = ws (w5 f x y z w) -end - let read_html_file () = let filename = Node.__dirname () ^ "/../astexplorer/dist/index.html" in Fs.readFile filename @@ -223,7 +195,7 @@ let on_hover custom_doc webview = if document_eq custom_doc document then send_msg "focus" (Ojs.int_to_js offset) ~webview; let hover = - Hover.make ~contents:(`MarkdownString (MarkdownString.make ~value:"" ())) + Hover.make ~contents:(`MarkdownString (MarkdownString.make ~value:"" ())) () in `Value (Some hover) in diff --git a/src/custom_requests.ml b/src/custom_requests.ml index d3e27da15..340131ec6 100644 --- a/src/custom_requests.ml +++ b/src/custom_requests.ml @@ -37,7 +37,7 @@ let typedHoles = } ;; -module Type_enclosing = struct +module Type_selection = struct type params = { uri : Uri.t ; at : [ `Position of Position.t | `Range of Range.t ] @@ -48,7 +48,7 @@ module Type_enclosing = struct type response = { index : int ; type_ : string - ; enclosings : Range.t list + ; enclosings : Range.t array } let encode_params { uri; at; index; verbosity } = @@ -69,7 +69,7 @@ module Type_enclosing = struct let open Jsonoo.Decode in let index = field "index" int response in let type_ = field "type" string response in - let enclosings = field "enclosings" (list Range.t_of_json) response in + let enclosings = field "enclosings" (array Range.t_of_json) response in { index; type_; enclosings } ;; diff --git a/src/custom_requests.mli b/src/custom_requests.mli index 3bdbdfe42..b6d7fade2 100644 --- a/src/custom_requests.mli +++ b/src/custom_requests.mli @@ -19,13 +19,13 @@ val switchImplIntf : (string, string array) custom_request val inferIntf : (string, string) custom_request val typedHoles : (Uri.t, Range.t list) custom_request -module Type_enclosing : sig +module Type_selection : sig type params type response = { index : int ; type_ : string - ; enclosings : Range.t list + ; enclosings : Range.t array } val make diff --git a/src/extension_commands.ml b/src/extension_commands.ml index ce6e02cf6..8866d06ec 100644 --- a/src/extension_commands.ml +++ b/src/extension_commands.ml @@ -489,7 +489,7 @@ end module Copy_type_under_cursor = struct let extension_name = "Copy Type Under Cursor" - let ocaml_lsp_doesnt_support_type_enclosing instance ocaml_lsp = + let ocaml_lsp_doesnt_support_type_selection instance ocaml_lsp = match Ocaml_lsp.is_version_up_to_date ocaml_lsp @@ -510,8 +510,8 @@ module Copy_type_under_cursor = struct Custom_requests.( send_request client - Type_enclosing.request - (Type_enclosing.make + Type_selection.request + (Type_selection.make ~uri ~at:(`Range (Selection.to_range selection)) ~index:0 @@ -531,13 +531,13 @@ module Copy_type_under_cursor = struct | Some text_editor -> (match Extension_instance.lsp_client instance with | None -> show_message `Warn "ocamllsp is not running" |> Promise.return - | Some (_, ocaml_lsp) when not (Ocaml_lsp.can_handle_type_enclosing ocaml_lsp) + | Some (_, ocaml_lsp) when not (Ocaml_lsp.can_handle_type_selection ocaml_lsp) -> - ocaml_lsp_doesnt_support_type_enclosing instance ocaml_lsp |> Promise.return + ocaml_lsp_doesnt_support_type_selection instance ocaml_lsp |> Promise.return | Some (client, _) -> let clipboard = Env.clipboard () in let open Promise.Syntax in - let* Custom_requests.Type_enclosing.{ type_; _ } = + let* Custom_requests.Type_selection.{ type_; _ } = get_enclosings text_editor client in if String.equal type_ "" @@ -1133,6 +1133,13 @@ module Navigate_holes = struct ;; end +let _type_selection = + let open Type_selection in + command Extension_consts.Commands.type_selection handler |> ignore; + command Extension_consts.Commands.type_previous_selection previous_handler |> ignore; + command Extension_consts.Commands.augment_selection_type_verbosity verbosity_handler +;; + 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 bd64772e5..4d4bbc165 100644 --- a/src/extension_consts.ml +++ b/src/extension_consts.ml @@ -37,6 +37,9 @@ module Commands = struct let merlin_jump = ocaml_prefixed "jump" let search_by_type = ocaml_prefixed "search-by-type" let navigate_typed_holes = ocaml_prefixed "navigate-typed-holes" + let type_selection = ocaml_prefixed "type-selection" + let type_previous_selection = ocaml_prefixed "type-previous-selection" + let augment_selection_type_verbosity = ocaml_prefixed "augment-selection-type-verbosity" end module Command_errors = struct diff --git a/src/extension_instance.ml b/src/extension_instance.ml index 9910b3768..5595eddec 100644 --- a/src/extension_instance.ml +++ b/src/extension_instance.ml @@ -13,6 +13,7 @@ type t = ; ast_editor_state : Ast_editor_state.t ; mutable codelens : bool option ; mutable extended_hover : bool option + ; mutable standard_hover : bool option ; mutable dune_diagnostics : bool option ; mutable syntax_documentation : bool option } @@ -26,6 +27,7 @@ let ocaml_version_exn t = Option.value_exn t.ocaml_version let send_configuration ~codelens ~extended_hover + ~standard_hover ~dune_diagnostics ~syntax_documentation client @@ -37,6 +39,10 @@ let send_configuration Option.map extended_hover ~f:(fun enable -> Ocaml_lsp.OcamllspSettingEnable.create ~enable) in + let standardHover = + Option.map standard_hover ~f:(fun enable -> + Ocaml_lsp.OcamllspSettingEnable.create ~enable) + in let duneDiagnostics = Option.map dune_diagnostics ~f:(fun enable -> Ocaml_lsp.OcamllspSettingEnable.create ~enable) @@ -49,6 +55,7 @@ let send_configuration Ocaml_lsp.OcamllspSettings.create ~codelens ~extendedHover + ~standardHover ~duneDiagnostics ~syntaxDocumentation in @@ -63,19 +70,31 @@ let send_configuration LanguageClient.sendNotification client "workspace/didChangeConfiguration" payload ;; -let set_configuration t ~codelens ~extended_hover ~dune_diagnostics ~syntax_documentation = - t.codelens <- codelens; - t.extended_hover <- extended_hover; - t.dune_diagnostics <- dune_diagnostics; - t.syntax_documentation <- syntax_documentation; +let set_configuration + t + ?codelens + ?extended_hover + ?standard_hover + ?dune_diagnostics + ?syntax_documentation + () + = + Option.iter codelens ~f:(fun codelens -> t.codelens <- codelens); + Option.iter extended_hover ~f:(fun extended_hover -> t.extended_hover <- extended_hover); + Option.iter standard_hover ~f:(fun standard_hover -> t.standard_hover <- standard_hover); + Option.iter dune_diagnostics ~f:(fun dune_diagnostics -> + t.dune_diagnostics <- dune_diagnostics); + Option.iter syntax_documentation ~f:(fun syntax_documentation -> + t.syntax_documentation <- syntax_documentation); match t.lsp_client with | None -> () | Some (client, (_ : Ocaml_lsp.t)) -> send_configuration - ~codelens - ~extended_hover - ~dune_diagnostics - ~syntax_documentation + ~codelens:t.codelens + ~extended_hover:t.extended_hover + ~standard_hover:t.standard_hover + ~dune_diagnostics:t.dune_diagnostics + ~syntax_documentation:t.syntax_documentation client ;; @@ -187,6 +206,7 @@ end = struct client ~codelens:t.codelens ~extended_hover:t.extended_hover + ~standard_hover:t.standard_hover ~dune_diagnostics:t.dune_diagnostics ~syntax_documentation:t.syntax_documentation; Ok () @@ -261,6 +281,7 @@ let make () = ; documentation_server = None ; codelens = None ; extended_hover = None + ; standard_hover = None ; dune_diagnostics = None ; syntax_documentation = None } diff --git a/src/extension_instance.mli b/src/extension_instance.mli index 2510cafc0..a9f4a9606 100644 --- a/src/extension_instance.mli +++ b/src/extension_instance.mli @@ -20,10 +20,12 @@ val start_language_server : t -> unit Promise.t val set_configuration : t - -> codelens:bool option - -> extended_hover:bool option - -> dune_diagnostics:bool option - -> syntax_documentation:bool option + -> ?codelens:bool option + -> ?extended_hover:bool option + -> ?standard_hover:bool option + -> ?dune_diagnostics:bool option + -> ?syntax_documentation:bool option + -> unit -> unit val open_terminal : Sandbox.t -> unit diff --git a/src/import.ml b/src/import.ml index cdb6586c3..787e5c839 100644 --- a/src/import.ml +++ b/src/import.ml @@ -253,3 +253,31 @@ module Ocaml_version = struct include Ocaml_version end + +exception User_error of string + +module Handlers = struct + let unpwrap = function + | `Ok () -> () + | `Error err_msg -> show_message `Error "%s" err_msg + ;; + + let w1 f x = + try `Ok (f x) with + | User_error e -> `Error e + ;; + + let ws f x y = + match f x with + | `Ok f' -> + (try `Ok (f' y) with + | User_error e -> `Error e) + | `Error e -> `Error e + ;; + + let w2 f = ws (w1 f) + let w3 f x = ws (w2 f x) + let w4 f x y = ws (w3 f x y) + let w5 f x y z = ws (w4 f x y z) + let _w6 f x y z w = ws (w5 f x y z w) +end diff --git a/src/ocaml_lsp.ml b/src/ocaml_lsp.ml index cda1f1477..60cf690b0 100644 --- a/src/ocaml_lsp.ml +++ b/src/ocaml_lsp.ml @@ -17,20 +17,29 @@ module OcamllspSettings = struct [%js: val codelens : t -> OcamllspSettingEnable.t or_undefined [@@js.get] val extendedHover : t -> OcamllspSettingEnable.t or_undefined [@@js.get] + val standardHover : t -> OcamllspSettingEnable.t or_undefined [@@js.get] val duneDiagnostics : t -> OcamllspSettingEnable.t or_undefined [@@js.get] val syntaxDocumentation : t -> OcamllspSettingEnable.t or_undefined [@@js.get] val create : ?codelens:OcamllspSettingEnable.t -> ?extendedHover:OcamllspSettingEnable.t + -> ?standardHover:OcamllspSettingEnable.t -> ?duneDiagnostics:OcamllspSettingEnable.t -> ?syntaxDocumentation:OcamllspSettingEnable.t -> unit -> t [@@js.builder]] - let create ~codelens ~extendedHover ~duneDiagnostics ~syntaxDocumentation = - create ?codelens ?extendedHover ?duneDiagnostics ?syntaxDocumentation () + let create ~codelens ~extendedHover ~standardHover ~duneDiagnostics ~syntaxDocumentation + = + create + ?codelens + ?extendedHover + ?standardHover + ?duneDiagnostics + ?syntaxDocumentation + () ;; end @@ -239,7 +248,7 @@ let of_initialize_result (t : LanguageClient.InitializeResult.t) = let can_handle_switch_impl_intf t = t.experimental_capabilities.handleSwitchImplIntf let can_handle_infer_intf t = t.experimental_capabilities.handleInferIntf let can_handle_typed_holes t = t.experimental_capabilities.handleTypedHoles -let can_handle_type_enclosing t = t.experimental_capabilities.handleTypeEnclosing +let can_handle_type_selection t = t.experimental_capabilities.handleTypeEnclosing let can_handle_construct t = t.experimental_capabilities.handleConstruct let can_handle_merlin_jump t = t.experimental_capabilities.handleJump let can_handle_search_by_type t = t.experimental_capabilities.handleSearchByType diff --git a/src/ocaml_lsp.mli b/src/ocaml_lsp.mli index afecac1df..b4fbc96ba 100644 --- a/src/ocaml_lsp.mli +++ b/src/ocaml_lsp.mli @@ -7,7 +7,7 @@ val is_version_up_to_date : t -> Ocaml_version.t -> (unit, [ `Msg of string ]) r val can_handle_switch_impl_intf : t -> bool val can_handle_infer_intf : t -> bool val can_handle_typed_holes : t -> bool -val can_handle_type_enclosing : t -> bool +val can_handle_type_selection : t -> bool val can_handle_construct : t -> bool val can_handle_merlin_jump : t -> bool val can_handle_search_by_type : t -> bool @@ -24,12 +24,14 @@ module OcamllspSettings : sig val codelens : t -> OcamllspSettingEnable.t option val extendedHover : t -> OcamllspSettingEnable.t option + val standardHover : t -> OcamllspSettingEnable.t option val duneDiagnostics : t -> OcamllspSettingEnable.t option val syntaxDocumentation : t -> OcamllspSettingEnable.t option val create : codelens:OcamllspSettingEnable.t option -> extendedHover:OcamllspSettingEnable.t option + -> standardHover:OcamllspSettingEnable.t option -> duneDiagnostics:OcamllspSettingEnable.t option -> syntaxDocumentation:OcamllspSettingEnable.t option -> t diff --git a/src/output.ml b/src/output.ml index 5b4a3f9da..b1f793c4a 100644 --- a/src/output.ml +++ b/src/output.ml @@ -1,11 +1,11 @@ let language_server_output_channel = - lazy (Vscode.Window.createOutputChannel ~name:"OCaml Language Server") + lazy (Vscode.Window.createOutputChannel ~name:"OCaml Language Server" ()) ;; let extension_output_channel = - lazy (Vscode.Window.createOutputChannel ~name:"OCaml Platform Extension") + lazy (Vscode.Window.createOutputChannel ~name:"OCaml Platform Extension" ()) ;; let command_output_channel = - lazy (Vscode.Window.createOutputChannel ~name:"OCaml Commands") + lazy (Vscode.Window.createOutputChannel ~name:"OCaml Commands" ()) ;; diff --git a/src/type_selection.ml b/src/type_selection.ml new file mode 100644 index 000000000..5a58f7513 --- /dev/null +++ b/src/type_selection.ml @@ -0,0 +1,307 @@ +open Import +module Request = Custom_requests.Type_selection + +module Options = struct + open Settings + + let outputChannelResults = + create_setting + ~scope:ConfigurationTarget.Workspace + ~key:"ocaml.commands.typeSelection.outputChannelResults" + ~of_json:Jsonoo.Decode.bool + ~to_json:Jsonoo.Encode.bool + ;; + + let alwaysClearOutputChannel = + create_setting + ~scope:ConfigurationTarget.Workspace + ~key:"ocaml.commands.typeSelection.alwaysClearOutputChannel" + ~of_json:Jsonoo.Decode.bool + ~to_json:Jsonoo.Encode.bool + ;; +end + +let register_hover_provider ~type_ range () = + let provider = + let provideHover ~(document : TextDocument.t) ~(position : Position.t) ~token:_ = + ignore (document, position); + let hover = + let contents = + let markdown_string = MarkdownString.make ~value:"" () in + `MarkdownString + (MarkdownString.appendCodeblock + markdown_string + ~value:type_ + ~language:"ocaml" + ()) + in + Hover.make ~contents ~range () + in + `Value (Some hover) + in + HoverProvider.create ~provideHover + in + Vscode.Languages.registerHoverProvider ~selector:(`String "ocaml") ~provider +;; + +let ocaml_lsp_doesnt_support_type_selection instance ocaml_lsp = + match + Ocaml_lsp.is_version_up_to_date + ocaml_lsp + (Extension_instance.ocaml_version_exn instance) + with + | Ok () -> () + | Error (`Msg msg) -> + show_message + `Warn + "The installed version of `ocamllsp` does not support type enclosings. %s" + msg +;; + +type state = + { initial_range : Range.t + ; text_editor : TextEditor.t + ; mutable last_result : Request.response option + ; mutable current_verbosity : int + ; mutable reset_disposable : Disposable.t + } + +let state : state option ref = ref None +let active_range (result : Request.response) = result.enclosings.(result.index) + +let next_index state = + match state.last_result with + | None -> 0 + | Some result -> + let number_or_enclosings = Array.length result.enclosings in + min (result.index + 1) (number_or_enclosings - 1) +;; + +let get_enclosings ?index text_editor client state = + let doc = TextEditor.document text_editor in + let uri = TextDocument.uri doc in + let index = Option.value_lazy ~default:(fun () -> next_index state) index in + let at = `Range state.initial_range in + let verbosity = state.current_verbosity in + Custom_requests.( + send_request + client + Type_selection.request + (Type_selection.make ~uri ~at ~index ~verbosity)) +;; + +let update_selection text_editor range = + let new_selection = + Selection.makePositions ~anchor:(Range.end_ range) ~active:(Range.start range) + in + TextEditor.set_selection text_editor new_selection +;; + +let output_channel = + Window.createOutputChannel ~name:"OCaml: Type of selection" ~languageId:"ocaml" () +;; + +let show_in_output_channel text_editor ~type_ range = + let doc = + let uri = TextEditor.document text_editor |> TextDocument.uri in + Uri.path uri + in + let line = + let pos = Range.start range in + Position.line pos + in + let header = Printf.sprintf "(* Line %i, file://%s *)\n" line doc in + (match Settings.(get Options.outputChannelResults) with + | None | Some true -> OutputChannel.show output_channel ~preserveFocus:true () + | Some false -> ()); + (match Settings.(get Options.alwaysClearOutputChannel) with + | Some true -> OutputChannel.replace output_channel ~value:header + | None | Some false -> OutputChannel.append output_channel ~value:header); + OutputChannel.appendLine output_channel ~value:type_; + OutputChannel.appendLine output_channel ~value:"" +;; + +(* To display customized information in the hover tooltip we need to register a + custom hover provider. However this does not prevent the standard hover + provider from showing which creates duplication and cluttering in the popup. + + Ideally we should be able to un-register the default hover provider easily on + the client side, but that's actually not something that is possible to do + with the official lsp client for vscode. The "builtin" feature is [registered here]( + https://github.com/microsoft/vscode-languageserver-node/blob/906f5fb306e1f6059cbdcb1efd962647222b5867/client/src/common/client.ts#L1970) + and the handler is not accessible. It might be possible to use dynamic + registration to activate / deactivate it, but that's an initiative of the + server and it doesn't feel like the correct way around. + + The present solution is to use an ad-hoc server option that allows the client + to mute the defaut hover responses (the server will answer with an empty + response.). *) +let display_type instance text_editor ({ type_; _ } as result : Request.response) = + let set_hover_active true_or_false = + Extension_instance.set_configuration instance ~standard_hover:(Some true_or_false) () + in + let range = active_range result in + update_selection text_editor range; + show_in_output_channel text_editor ~type_ range; + let () = set_hover_active false in + (* Mute the standard hover provider *) + let hover_provider_disposable = register_hover_provider ~type_ range () in + let open Promise.Syntax in + let+ _ = Commands.executeCommand ~command:"editor.action.showHover" ~args:[] in + let () = set_hover_active true in + (* Un-mute the standard hover provider *) + Disposable.dispose hover_provider_disposable +;; + +let with_checks ~extension_name ~instance f = + match Window.activeTextEditor () with + | None -> + Extension_consts.Command_errors.text_editor_must_be_active + extension_name + ~expl:"The command relies on the current editor selection." + |> show_message `Error "%s" + |> Promise.return + | Some text_editor -> + (match Extension_instance.lsp_client instance with + | None -> show_message `Warn "ocamllsp is not running" |> Promise.return + | Some (_, ocaml_lsp) when not (Ocaml_lsp.can_handle_type_selection ocaml_lsp) -> + ocaml_lsp_doesnt_support_type_selection instance ocaml_lsp |> Promise.return + | Some (client, _) -> f text_editor client) +;; + +let extension_name = "Type Selection" + +(* We should reset the state if the selection change or the user switches + editor *) +let enable_reset () = + let onDidChangeTextEditorSelection_listener event = + let selections = TextEditorSelectionChangeEvent.selections event in + let not_last_range (result : Request.response) range = + let other = result.enclosings.(result.index) in + not (Range.isEqual ~other range) + in + Option.iter !state ~f:(fun last_state -> + match last_state.last_result, selections with + | Some last_result, [ s ] when not_last_range last_result (Selection.to_range s) -> + Disposable.dispose last_state.reset_disposable; + state := None + | _ -> ()) + in + let onDidChangeActiveTextEditor_listener _text_editor = + match !state with + | Some current_state -> + Disposable.dispose current_state.reset_disposable; + state := None + | _ -> () + in + [ (let listener event = + let listener = onDidChangeTextEditorSelection_listener in + Handlers.unpwrap (Handlers.w1 listener event) + in + Window.onDidChangeTextEditorSelection () ~listener ()) + ; (let listener event = + let listener = onDidChangeActiveTextEditor_listener in + Handlers.unpwrap (Handlers.w1 listener event) + in + Window.onDidChangeActiveTextEditor () ~listener ()) + ] +;; + +(* There might be duplicates in the enclosing list which are complex to filter + out on the server-side for performance reasons *) +let is_duplicate last_result result = + match last_result with + | None -> false + | Some last_result -> + let last_range = active_range last_result in + let other = active_range result in + Range.isEqual last_range ~other && String.equal last_result.type_ result.type_ +;; + +let last_index state = + match state.last_result with + | None -> -1 + | Some last_result -> last_result.index +;; + +let rec type_selection ~instance ?(verbosity = 0) () = + with_checks ~extension_name ~instance + @@ fun text_editor client -> + let open Promise.Syntax in + let state = + match !state with + | Some state -> state + | None -> + let initial_range = TextEditor.selection text_editor |> Selection.to_range in + let new_state = + { initial_range + ; text_editor + ; current_verbosity = 0 + ; last_result = None + ; reset_disposable = Disposable.from @@ enable_reset () + } + in + state := Some new_state; + new_state + in + state.current_verbosity <- verbosity; + let* result = get_enclosings text_editor client state in + match result.enclosings with + | [||] -> + show_message `Warn "No results found for that selection."; + Promise.return () + | _ -> + let previous_result = state.last_result in + let previous_index = last_index state in + state.last_result <- Some result; + if is_duplicate previous_result result && next_index state > previous_index + then type_selection ~instance () + else display_type instance text_editor result +;; + +let handler (instance : Extension_instance.t) ~args:_ = + let (_ : unit Promise.t) = type_selection ~instance () in + () +;; + +let extension_name = "Type Previous Selection" + +let previous_handler (instance : Extension_instance.t) ~args:_ = + let type_previous_selection () = + with_checks ~extension_name ~instance + @@ fun text_editor client -> + let open Promise.Syntax in + match !state with + | None -> Promise.return @@ show_message `Warn "There is no previous selection" + | Some state -> + let index = max 0 (last_index state - 1) in + let* result = get_enclosings text_editor client ~index state in + state.last_result <- Some result; + display_type instance text_editor result + in + let (_ : unit Promise.t) = type_previous_selection () in + () +;; + +let extension_name = "Increase Selection Type Verbosity" + +let verbosity_handler (instance : Extension_instance.t) ~args:_ = + let bump_selection_type_verbosity () = + with_checks ~extension_name ~instance + @@ fun text_editor client -> + let open Promise.Syntax in + match !state with + | None -> type_selection ~instance ~verbosity:1 () + | Some state -> + let index = + match state.last_result with + | None -> 0 + | Some last_result -> last_result.index + in + state.current_verbosity <- state.current_verbosity + 1; + let* result = get_enclosings text_editor client ~index state in + display_type instance text_editor result + in + let (_ : unit Promise.t) = bump_selection_type_verbosity () in + () +;; diff --git a/src/vscode_ocaml_platform.ml b/src/vscode_ocaml_platform.ml index 5a65918bd..45f686abf 100644 --- a/src/vscode_ocaml_platform.ml +++ b/src/vscode_ocaml_platform.ml @@ -33,7 +33,8 @@ let notify_configuration_changes instance = ~codelens ~extended_hover ~dune_diagnostics - ~syntax_documentation) + ~syntax_documentation + ()) () ;; From 6d7a3ed370d07ee3f42bfbd76ab541c27b432c8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Tue, 14 Jan 2025 16:26:05 +0100 Subject: [PATCH 2/2] Add changelog entry for #1675 --- CHANGELOG.md | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 82ba66069..b44c04ec2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,13 @@ # Unreleased +- Add `ocaml.type-selection` that shows the type of the expression around the + cursor or selection. Repeated calls show the type of larger enclosing nodes + around the initial selection. Additional commands + `ocaml.type-previous-selection` and `ocaml.augment-selection-type-verbosity` + can be used to shrink the selection and increase the verbosity of the + displayed type. (#1675) + ## 1.26.1 - Construct: display a message when construct list is empty. (#1695)