diff --git a/package.json b/package.json index f813c186b..8c6e63aeb 100644 --- a/package.json +++ b/package.json @@ -262,6 +262,21 @@ "command": "ocaml.jump", "category": "OCaml", "title": "List possible parent targets for jumping" + }, + { + "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": { @@ -301,6 +316,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, @@ -770,7 +795,22 @@ { "command": "ocaml.switch-hover-mode", "key": "Alt+H", - "when": "editorTextFocus && editorLangId == ocaml || editorLangId == ocaml.interface " + "when": "editorTextFocus && editorLangId == ocaml || editorLangId == ocaml.interface" + }, + { + "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 636fe9acd..147cc4ef6 100644 --- a/src-bindings/vscode/vscode.ml +++ b/src-bindings/vscode/vscode.ml @@ -581,6 +581,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 () @@ -755,6 +790,33 @@ module TextEditor = struct insertSnippet this ~snippet ?location options 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] @@ -1519,6 +1581,8 @@ module OutputChannel = struct 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] @@ -1961,6 +2025,8 @@ module Hover = struct | `MarkdownStringArray of MarkdownString.t list ] [@js.union]) + -> ?range:Range.t + -> unit -> t [@@js.new "vscode.Hover"]] end @@ -2977,6 +3043,10 @@ 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 @@ -3007,6 +3077,10 @@ 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 @@ -3058,7 +3132,8 @@ module Window = struct ?options:OpenDialogOptions.t -> unit -> Uri.t list or_undefined Promise.t [@@js.global "vscode.window.showOpenDialog"] - val createOutputChannel : name:string -> OutputChannel.t + val createOutputChannel : + name:string -> ?languageId:string -> unit -> OutputChannel.t [@@js.global "vscode.window.createOutputChannel"] val setStatusBarMessage : diff --git a/src-bindings/vscode/vscode.mli b/src-bindings/vscode/vscode.mli index a4364f39d..b64f32c1b 100644 --- a/src-bindings/vscode/vscode.mli +++ b/src-bindings/vscode/vscode.mli @@ -471,6 +471,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 @@ -600,6 +632,31 @@ module TextEditor : sig t -> range:Range.t -> ?revealType:TextEditorRevealType.t -> unit -> 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 @@ -1175,6 +1232,8 @@ module OutputChannel : sig val appendLine : t -> value:string -> unit + val replace : t -> value:string -> unit + val clear : t -> unit val show : t -> ?preserveFocus:bool -> unit -> unit @@ -1523,6 +1582,8 @@ module Hover : sig [ `MarkdownString of MarkdownString.t | `MarkdownStringArray of MarkdownString.t list ] + -> ?range:Range.t + -> unit -> t end @@ -2300,6 +2361,9 @@ module Window : sig 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 @@ -2323,6 +2387,9 @@ module Window : sig -> unit -> TextEditor.t Promise.t + val createTextEditorDecorationType : + options:DecorationRenderOptions.t -> TextEditorDecorationType.t + val showInformationMessage : message:string -> ?options:MessageOptions.t @@ -2367,7 +2434,8 @@ module Window : sig 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 -> ?hide:[ `AfterTimeout of int ] -> unit -> Disposable.t diff --git a/src/ast_editor.ml b/src/ast_editor.ml index cf25e065d..c987f080f 100644 --- a/src/ast_editor.ml +++ b/src/ast_editor.ml @@ -1,30 +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 @@ -218,6 +193,7 @@ let on_hover custom_doc webview = let hover = 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 7dc47d74f..817e2ab78 100644 --- a/src/custom_requests.ml +++ b/src/custom_requests.ml @@ -34,7 +34,7 @@ let typedHoles = ; decode_response = Jsonoo.Decode.list Range.t_of_json } -module Type_enclosing = struct +module Type_selection = struct type params = { uri : Uri.t ; at : [ `Position of Position.t | `Range of Range.t ] @@ -45,7 +45,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 } = @@ -65,7 +65,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 } let make ~uri ~at ~index ~verbosity = { uri; at; index; verbosity } diff --git a/src/custom_requests.mli b/src/custom_requests.mli index 46bff0b15..161740995 100644 --- a/src/custom_requests.mli +++ b/src/custom_requests.mli @@ -21,13 +21,13 @@ 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 ee342d30e..9d17d0604 100644 --- a/src/extension_commands.ml +++ b/src/extension_commands.ml @@ -496,7 +496,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 @@ -517,8 +517,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 @@ -538,13 +538,13 @@ module Copy_type_under_cursor = struct | None -> show_message `Warn "ocamllsp is not running" |> Promise.return | Some (_, ocaml_lsp) - when not (Ocaml_lsp.can_handle_type_enclosing ocaml_lsp) -> - ocaml_lsp_doesnt_support_type_enclosing instance 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, _) -> 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_ "" then @@ -766,6 +766,15 @@ module MerlinJump = struct command Extension_consts.Commands.merlin_jump handler 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 b49751873..031ab8505 100644 --- a/src/extension_consts.ml +++ b/src/extension_consts.ml @@ -72,6 +72,13 @@ module Commands = struct let construct = ocaml_prefixed "construct" let merlin_jump = ocaml_prefixed "jump" + + 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 863471b04..39537c782 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 } @@ -27,8 +28,8 @@ let lsp_client t = t.lsp_client let ocaml_version_exn t = Option.value_exn t.ocaml_version -let send_configuration ~codelens ~extended_hover ~dune_diagnostics - ~syntax_documentation client = +let send_configuration ~codelens ~extended_hover ~standard_hover + ~dune_diagnostics ~syntax_documentation client = let codelens = Option.map codelens ~f:(fun enable -> Ocaml_lsp.OcamllspSettingEnable.create ~enable) @@ -37,6 +38,10 @@ let send_configuration ~codelens ~extended_hover ~dune_diagnostics 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 +54,7 @@ let send_configuration ~codelens ~extended_hover ~dune_diagnostics Ocaml_lsp.OcamllspSettings.create ~codelens ~extendedHover + ~standardHover ~duneDiagnostics ~syntaxDocumentation in @@ -65,20 +71,26 @@ let send_configuration ~codelens ~extended_hover ~dune_diagnostics "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 let stop_server t = @@ -201,6 +213,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 () @@ -274,6 +287,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 ea315d694..e70d7290f 100644 --- a/src/extension_instance.mli +++ b/src/extension_instance.mli @@ -25,10 +25,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 0976f3f6d..a7e1ff526 100644 --- a/src/import.ml +++ b/src/import.ml @@ -209,3 +209,28 @@ 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 e2362ddea..82cbe3a90 100644 --- a/src/ocaml_lsp.ml +++ b/src/ocaml_lsp.ml @@ -20,6 +20,8 @@ module OcamllspSettings = struct 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 @@ -28,14 +30,22 @@ module OcamllspSettings = struct 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 module Experimental_capabilities = struct @@ -245,7 +255,7 @@ 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 = +let can_handle_type_selection t = t.experimental_capabilities.handleTypeEnclosing let can_handle_construct t = t.experimental_capabilities.handleConstruct diff --git a/src/ocaml_lsp.mli b/src/ocaml_lsp.mli index b385ab9c7..70cee0f3f 100644 --- a/src/ocaml_lsp.mli +++ b/src/ocaml_lsp.mli @@ -13,7 +13,7 @@ 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 @@ -34,6 +34,8 @@ module OcamllspSettings : sig val extendedHover : t -> OcamllspSettingEnable.t option + val standardHover : t -> OcamllspSettingEnable.t option + val duneDiagnostics : t -> OcamllspSettingEnable.t option val syntaxDocumentation : t -> OcamllspSettingEnable.t option @@ -41,6 +43,7 @@ module OcamllspSettings : sig 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 dc53ff532..28f1cc8fa 100644 --- a/src/output.ml +++ b/src/output.ml @@ -1,8 +1,8 @@ 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..1fe224403 --- /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 e3da72221..96568d76c 100644 --- a/src/vscode_ocaml_platform.ml +++ b/src/vscode_ocaml_platform.ml @@ -34,7 +34,8 @@ let notify_configuration_changes instance = ~codelens ~extended_hover ~dune_diagnostics - ~syntax_documentation) + ~syntax_documentation + ()) () let activate (extension : ExtensionContext.t) =