From ad5e67d177ef4d906fc67f37f77278266a590c24 Mon Sep 17 00:00:00 2001 From: PizieDust Date: Mon, 21 Oct 2024 12:10:07 +0200 Subject: [PATCH] Search By Type or Polarity MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Ulysse Gérard --- CHANGELOG.md | 2 + README.md | 3 +- package.json | 14 ++ src-bindings/vscode/vscode.ml | 294 ++++++++++++++++++++++++++++----- src-bindings/vscode/vscode.mli | 198 +++++++++++++++++++--- src/custom_requests.ml | 64 +++++++ src/custom_requests.mli | 26 +++ src/extension_commands.ml | 197 ++++++++++++++++++++++ src/extension_consts.ml | 1 + src/import.ml | 36 +++- src/ocaml_lsp.ml | 5 + src/ocaml_lsp.mli | 1 + src/treeview_commands.ml | 27 ++- src/treeview_help.ml | 6 +- src/treeview_sandbox.ml | 2 +- src/treeview_switches.ml | 4 +- 16 files changed, 801 insertions(+), 79 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index bfd5bca84..0e3fbb925 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,8 @@ # Unreleased +- Add `ocaml.search-by-type` to search for values using their type signature (#1626) + ## 1.24.0 - Add `ocaml.commands.construct.recursiveCalls` setting to configure construct chaining. (#1673) diff --git a/README.md b/README.md index c19ae8988..bd3fccb8e 100644 --- a/README.md +++ b/README.md @@ -254,7 +254,7 @@ prefix `OCaml:`: ![commands](./doc/commands.png) | Name | Description | Keyboard Shortcuts | -| -------------------------------| ------------------------------------------- | ------------------ | +| ------------------------------ | ------------------------------------------- | ------------------ | | `ocaml.select-sandbox` | Select sandbox for this workspace | | | `ocaml.server.restart` | Restart language server | | | `ocaml.open-terminal` | Open a terminal (current sandbox) | | @@ -264,6 +264,7 @@ prefix `OCaml:`: | `ocaml.open-repl` | Open REPL | | | `ocaml.evaluate-selection` | Evaluate Selection | `Shift+Enter` | | `ocaml.copy-type-under-cursor` | Copy the type under the cursor | | +| `ocaml.search-by-type` | Search a value by type or polarity | `Alt+F` | ## Debugging OCaml programs (experimental) diff --git a/package.json b/package.json index 66fc4a3fa..9cc54b60a 100644 --- a/package.json +++ b/package.json @@ -262,6 +262,11 @@ "command": "ocaml.jump", "category": "OCaml", "title": "List possible parent targets for jumping" + }, + { + "command": "ocaml.search-by-type", + "category": "OCaml", + "title": "Search a value by type or polarity" } ], "configuration": { @@ -776,6 +781,11 @@ "command": "ocaml.switch-hover-mode", "key": "Alt+H", "when": "editorTextFocus && editorLangId == ocaml || editorLangId == ocaml.interface " + }, + { + "command": "ocaml.search-by-type", + "key": "Alt+F", + "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason || editorLangId == ocaml.ocamllex" } ], "languages": [ @@ -1067,6 +1077,10 @@ { "command": "ocaml.construct", "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason || editorLangId == ocaml.ocamllex" + }, + { + "command": "ocaml.search-by-type", + "when": "editorLangId == ocaml || editorLangId == ocaml.interface || editorLangId == reason || editorLangId == ocaml.ocamllex" } ], "editor/title": [ diff --git a/src-bindings/vscode/vscode.ml b/src-bindings/vscode/vscode.ml index 7c5aa8f29..1d79dbdce 100644 --- a/src-bindings/vscode/vscode.ml +++ b/src-bindings/vscode/vscode.ml @@ -178,6 +178,49 @@ module Uri = struct let equal a b = String.equal (toString a ()) (toString b ()) end +module LightDarkIcon = struct + type t = + { light : ([ `String of string | `Uri of Uri.t ][@js.union]) + ; dark : ([ `String of string | `Uri of Uri.t ][@js.union]) + } + [@@js] + + let t_of_js js_val = + let light_js = Ojs.get_prop_ascii js_val "light" in + let dark_js = Ojs.get_prop_ascii js_val "dark" in + let light = + if Ojs.has_property light_js "parse" + then `Uri ([%js.to: Uri.t] light_js) + else `String ([%js.to: string] light_js) + in + let dark = + if Ojs.has_property dark_js "parse" + then `Uri ([%js.to: Uri.t] dark_js) + else `String ([%js.to: string] dark_js) + in + { light; dark } + ;; +end + +module ThemeColor = struct + include Class.Make () + include [%js: val make : id:string -> t [@@js.new "vscode.ThemeColor"]] +end + +module ThemeIcon = struct + include Class.Make () + + include + [%js: + val make : id:string -> ?color:ThemeColor.t -> unit -> t + [@@js.new "vscode.ThemeIcon"] + + val file : t [@@js.global "vscode.ThemeIcon.File"] + val folder : t [@@js.global "vscode.ThemeIcon.Folder"] + val id : t -> string [@@js.get] + val color : t -> ThemeColor.t or_undefined [@@js.get]] +end + module TextDocument = struct include Interface.Make () @@ -425,11 +468,6 @@ module MarkdownString = struct val appendCodeblock : t -> value:string -> ?language:string -> unit -> t [@@js.call]] end -module ThemeColor = struct - include Class.Make () - include [%js: val make : id:string -> t [@@js.new "vscode.ThemeColor"]] -end - module ThemableDecorationAttachmentRenderOptions = struct include Interface.Make () @@ -897,6 +935,34 @@ module CancellationToken = struct [@@js.builder]] end +module QuickInputButton = struct + include Interface.Make () + + type iconPath = + ([ `Uri of Uri.t + | `LightDark of LightDarkIcon.t + | `ThemeIcon of ThemeIcon.t + ] + [@js.union]) + [@@js] + + let iconPath_of_js js_val = + if Ojs.has_property js_val "path" + then `Uri ([%js.to: Uri.t] js_val) + else if Ojs.has_property js_val "id" + then `ThemeIcon ([%js.to: ThemeIcon.t] js_val) + else if Ojs.has_property js_val "light" + then `LightDark ([%js.to: LightDarkIcon.t] js_val) + else assert false + ;; + + include + [%js: + val iconPath : t -> iconPath [@@js.get] + val tooltip : t -> string or_undefined [@@js.get] + val create : iconPath:iconPath -> ?tooltip:string -> unit -> t [@@js.builder]] +end + module QuickPickItem = struct include Interface.Make () @@ -958,6 +1024,98 @@ module QuickPickOptions = struct [@@js.builder]] end +module QuickPick = struct + module G = Interface.Generic (Ojs) () + include G + + module Make (T : Ojs.T) = struct + type t = T.t G.t [@@js] + + include + [%js: + val onDidAccept : t -> unit Event.t [@@js.get] + val onDidChangeActive : t -> T.t list Event.t [@@js.get] + val onDidChangeSelection : t -> T.t list Event.t [@@js.get] + val onDidChangeValue : t -> string Event.t [@@js.get] + val onDidHide : t -> unit Event.t [@@js.get] + val onDidTriggerButton : t -> QuickInputButton.t Event.t [@@js.get] + val activeItems : t -> T.t list or_undefined [@@js.get] + val set_activeItems : t -> T.t list or_undefined -> unit [@@js.set] + val busy : t -> bool or_undefined [@@js.get] + val set_busy : t -> bool or_undefined -> unit [@@js.set] + val buttons : t -> QuickInputButton.t list or_undefined [@@js.get] + val set_buttons : t -> QuickInputButton.t list or_undefined -> unit [@@js.set] + val canSelectMany : t -> bool or_undefined [@@js.get] + val set_canSelectMany : t -> bool or_undefined -> unit [@@js.set] + val enabled : t -> bool or_undefined [@@js.get] + val set_enabled : t -> bool or_undefined -> unit [@@js.set] + val ignoreFocusOut : t -> bool or_undefined [@@js.get] + val set_ignoreFocusOut : t -> bool or_undefined -> unit [@@js.set] + val items : t -> T.t list or_undefined [@@js.get] + val set_items : t -> T.t list or_undefined -> unit [@@js.set] + val keepScrollPosition : t -> bool or_undefined [@@js.get] + val set_keepScrollPosition : t -> bool or_undefined -> unit [@@js.set] + val matchOnDescription : t -> bool or_undefined [@@js.get] + val set_matchOnDescription : t -> bool or_undefined -> unit [@@js.set] + val matchOnDetail : t -> bool or_undefined [@@js.get] + val set_matchOnDetail : t -> bool or_undefined -> unit [@@js.set] + val placeholder : t -> string or_undefined [@@js.get] + val set_placeholder : t -> string or_undefined -> unit [@@js.set] + val selectedItems : t -> T.t list or_undefined [@@js.get] + val set_selectedItems : t -> T.t list or_undefined -> unit [@@js.set] + val step : t -> int or_undefined [@@js.get] + val set_step : t -> int or_undefined -> unit [@@js.set] + val title : t -> string or_undefined [@@js.get] + val set_title : t -> string or_undefined -> unit [@@js.set] + val totalSteps : t -> int or_undefined [@@js.get] + val set_totalSteps : t -> int or_undefined -> unit [@@js.set] + val value : t -> string or_undefined [@@js.get] + val set_value : t -> string or_undefined -> unit [@@js.set] + val dispose : t -> unit [@@js.call] + val hide : t -> unit [@@js.call] + val show : t -> unit [@@js.call]] + + let set + t + ?activeItems + ?busy + ?buttons + ?canSelectMany + ?enabled + ?ignoreFocusOut + ?items + ?keepScrollPosition + ?matchOnDescription + ?matchOnDetail + ?placeholder + ?selectedItems + ?step + ?title + ?totalSteps + ?value + () + = + set_activeItems t activeItems; + set_busy t busy; + set_buttons t buttons; + set_canSelectMany t canSelectMany; + set_enabled t enabled; + set_ignoreFocusOut t ignoreFocusOut; + set_items t items; + set_keepScrollPosition t keepScrollPosition; + set_matchOnDescription t matchOnDescription; + set_matchOnDetail t matchOnDetail; + set_placeholder t placeholder; + set_selectedItems t selectedItems; + set_step t step; + set_title t title; + set_totalSteps t totalSteps; + set_value t value; + t + ;; + end +end + module ProviderResult = struct type 'a t = [ `Value of 'a or_undefined @@ -976,6 +1134,26 @@ module ProviderResult = struct ;; end +module InputBoxValidationSeverity = struct + type t = + | Info [@js 1] + | Warning [@js 2] + | Error [@js 3] + [@@js.enum] [@@js] +end + +module InputBoxValidationMessage = struct + include Interface.Make () + + include + [%js: + val message : t -> string [@@js.get] + val severity : t -> InputBoxValidationSeverity.t [@@js.get] + + val create : message:string -> severity:InputBoxValidationSeverity.t -> unit -> t + [@@js.builder]] +end + module InputBoxOptions = struct include Interface.Make () @@ -1004,6 +1182,63 @@ module InputBoxOptions = struct [@@js.builder]] end +module InputBox = struct + include Interface.Make () + + include + [%js: + val title : t -> string or_undefined [@@js.get] + val set_title : t -> string or_undefined -> unit [@@js.set] + val enabled : t -> bool [@@js.get] + val set_enabled : t -> bool -> unit [@@js.set] + val busy : t -> bool [@@js.get] + val set_busy : t -> bool -> unit [@@js.set] + val ignoreFocusOut : t -> bool or_undefined [@@js.get] + val set_ignoreFocusOut : t -> bool or_undefined -> unit [@@js.set] + val onDidHide : t -> unit Event.t [@@js.get] + val value : t -> string or_undefined [@@js.get] + val set_value : t -> string or_undefined -> unit [@@js.set] + val valueSelection : t -> (int * int) or_undefined [@@js.get] + val set_valueSelection : t -> (int * int) or_undefined -> unit [@@js.set] + val placeholder : t -> string or_undefined [@@js.get] + val set_placeholder : t -> string or_undefined -> unit [@@js.set] + val password : t -> bool or_undefined [@@js.get] + val set_password : t -> bool or_undefined -> unit [@@js.set] + val onDidChangeValue : t -> string Event.t [@@js.get] + val onDidAccept : t -> unit Event.t [@@js.get] + val prompt : t -> string or_undefined [@@js.get] + val set_prompt : t -> string or_undefined -> unit [@@js.set] + val validationMessage : t -> InputBoxValidationMessage.t or_undefined [@@js.get] + + val set_validationMessage : t -> InputBoxValidationMessage.t or_undefined -> unit + [@@js.set] + + val show : t -> unit [@@js.call]] + + let set + t + ?title + ?ignoreFocusOut + ?value + ?valueSelection + ?placeholder + ?password + ?prompt + ?validationMessage + () + = + set_title t title; + set_ignoreFocusOut t ignoreFocusOut; + set_value t value; + set_valueSelection t valueSelection; + set_placeholder t placeholder; + set_password t password; + set_prompt t prompt; + set_validationMessage t validationMessage; + t + ;; +end + module OpenDialogOptions = struct include Interface.Make () @@ -2169,20 +2404,6 @@ module TreeItemLabel = struct [@@js.builder]] end -module ThemeIcon = struct - include Class.Make () - - include - [%js: - val make : id:string -> ?color:ThemeColor.t -> unit -> t - [@@js.new "vscode.ThemeIcon"] - - val file : t [@@js.global "vscode.ThemeIcon.File"] - val folder : t [@@js.global "vscode.ThemeIcon.Folder"] - val id : t -> string [@@js.get] - val color : t -> ThemeColor.t or_undefined [@@js.get]] -end - module TreeItem = struct include Class.Make () @@ -2201,30 +2422,6 @@ module TreeItem = struct else assert false ;; - module LightDarkIcon = struct - type t = - { light : ([ `String of string | `Uri of Uri.t ][@js.union]) - ; dark : ([ `String of string | `Uri of Uri.t ][@js.union]) - } - [@@js] - - let t_of_js js_val = - let light_js = Ojs.get_prop_ascii js_val "light" in - let dark_js = Ojs.get_prop_ascii js_val "dark" in - let light = - if Ojs.has_property light_js "parse" - then `Uri ([%js.to: Uri.t] light_js) - else `String ([%js.to: string] light_js) - in - let dark = - if Ojs.has_property dark_js "parse" - then `Uri ([%js.to: Uri.t] dark_js) - else `String ([%js.to: string] dark_js) - in - { light; dark } - ;; - end - type iconPath = ([ `String of string | `Uri of Uri.t @@ -2758,6 +2955,12 @@ module Window = struct -> MessageItem.t or_undefined Promise.t [@@js.global "vscode.window.showErrorMessage"] + val createQuickPick + : ((module Ojs.T with type t = 'a)[@js]) + -> unit + -> 'a QuickPick.t + [@@js.global "vscode.window.createQuickPick"] + val showQuickPickItems : choices:QuickPickItem.t list -> ?options:QuickPickOptions.t @@ -2774,6 +2977,9 @@ module Window = struct -> string or_undefined Promise.t [@@js.global "vscode.window.showQuickPick"] + val quickInputButtonBack : QuickInputButton.t + [@@js.global "vscode.QuickInputButtons.Back"] + val showInputBox : ?options:InputBoxOptions.t -> ?token:CancellationToken.t @@ -2781,6 +2987,8 @@ module Window = struct -> string or_undefined Promise.t [@@js.global "vscode.window.showInputBox"] + val createInputBox : unit -> InputBox.t [@@js.global "vscode.window.createInputBox"] + val showOpenDialog : ?options:OpenDialogOptions.t -> unit diff --git a/src-bindings/vscode/vscode.mli b/src-bindings/vscode/vscode.mli index ebdbc6824..514e8664b 100644 --- a/src-bindings/vscode/vscode.mli +++ b/src-bindings/vscode/vscode.mli @@ -144,6 +144,31 @@ module Uri : sig val equal : t -> t -> bool end +module LightDarkIcon : sig + type t = + { light : [ `String of string | `Uri of Uri.t ] + ; dark : [ `String of string | `Uri of Uri.t ] + } + + include Ojs.T with type t := t +end + +module ThemeColor : sig + include Ojs.T + + val make : id:string -> t +end + +module ThemeIcon : sig + include Ojs.T + + val make : id:string -> ?color:ThemeColor.t -> unit -> t + val file : t + val folder : t + val id : t -> string + val color : t -> ThemeColor.t option +end + module TextDocument : sig include Ojs.T @@ -331,12 +356,6 @@ module MarkdownString : sig val appendCodeblock : t -> value:string -> ?language:string -> unit -> t end -module ThemeColor : sig - include Ojs.T - - val make : id:string -> t -end - module ThemableDecorationAttachmentRenderOptions : sig include Ojs.T @@ -668,6 +687,20 @@ module CustomDocument : sig val create : uri:Uri.t -> dispose:(unit -> unit) -> t end +module QuickInputButton : sig + include Ojs.T + + type iconPath = + [ `Uri of Uri.t + | `LightDark of LightDarkIcon.t + | `ThemeIcon of ThemeIcon.t + ] + + val iconPath : t -> iconPath + val tooltip : t -> string option + val create : iconPath:iconPath -> ?tooltip:string -> unit -> t +end + module QuickPickItem : sig include Ojs.T @@ -715,6 +748,77 @@ module QuickPickOptions : sig -> t end +module QuickPick : sig + include Js.Generic + + module Make (T : Ojs.T) : sig + type nonrec t = T.t t + + val onDidAccept : t -> unit Event.t + val onDidChangeActive : t -> T.t list Event.t + val onDidChangeSelection : t -> T.t list Event.t + val onDidChangeValue : t -> string Event.t + val onDidHide : t -> unit Event.t + val onDidTriggerButton : t -> QuickInputButton.t Event.t + val activeItems : t -> T.t list option + val set_activeItems : t -> T.t list option -> unit + val busy : t -> bool option + val set_busy : t -> bool option -> unit + val buttons : t -> QuickInputButton.t list option + val set_buttons : t -> QuickInputButton.t list option -> unit + val canSelectMany : t -> bool option + val set_canSelectMany : t -> bool option -> unit + val enabled : t -> bool option + val set_enabled : t -> bool option -> unit + val ignoreFocusOut : t -> bool option + val set_ignoreFocusOut : t -> bool option -> unit + val items : t -> T.t list option + val set_items : t -> T.t list option -> unit + val keepScrollPosition : t -> bool option + val set_keepScrollPosition : t -> bool option -> unit + val matchOnDescription : t -> bool option + val set_matchOnDescription : t -> bool option -> unit + val matchOnDetail : t -> bool option + val set_matchOnDetail : t -> bool option -> unit + val placeholder : t -> string option + val set_placeholder : t -> string option -> unit + val selectedItems : t -> T.t list option + val set_selectedItems : t -> T.t list option -> unit + val step : t -> int option + val set_step : t -> int option -> unit + val title : t -> string option + val set_title : t -> string option -> unit + val totalSteps : t -> int option + val set_totalSteps : t -> int option -> unit + val value : t -> string option + val set_value : t -> string option -> unit + val dispose : t -> unit + val hide : t -> unit + val show : t -> unit + + val set + : t + -> ?activeItems:T.t list + -> ?busy:bool + -> ?buttons:QuickInputButton.t list + -> ?canSelectMany:bool + -> ?enabled:bool + -> ?ignoreFocusOut:bool + -> ?items:T.t list + -> ?keepScrollPosition:bool + -> ?matchOnDescription:bool + -> ?matchOnDetail:bool + -> ?placeholder:string + -> ?selectedItems:T.t list + -> ?step:int + -> ?title:string + -> ?totalSteps:int + -> ?value:string + -> unit + -> t + end +end + module ProviderResult : sig type 'a t = [ `Value of 'a option @@ -724,6 +828,23 @@ module ProviderResult : sig include Js.Generic with type 'a t := 'a t end +module InputBoxValidationSeverity : sig + type t = + | Info + | Warning + | Error + + include Ojs.T with type t := t +end + +module InputBoxValidationMessage : sig + include Ojs.T + + val message : t -> string + val severity : t -> InputBoxValidationSeverity.t + val create : message:string -> severity:InputBoxValidationSeverity.t -> unit -> t +end + module InputBoxOptions : sig include Ojs.T @@ -749,6 +870,48 @@ module InputBoxOptions : sig -> t end +module InputBox : sig + include Ojs.T + + val title : t -> string option + val set_title : t -> string option -> unit + val enabled : t -> bool + val set_enabled : t -> bool -> unit + val busy : t -> bool + val set_busy : t -> bool -> unit + val ignoreFocusOut : t -> bool option + val set_ignoreFocusOut : t -> bool option -> unit + val onDidHide : t -> unit Event.t + val value : t -> string option + val set_value : t -> string option -> unit + val valueSelection : t -> (int * int) option + val set_valueSelection : t -> (int * int) option -> unit + val placeholder : t -> string option + val set_placeholder : t -> string option -> unit + val password : t -> bool option + val set_password : t -> bool option -> unit + val onDidChangeValue : t -> string Event.t + val onDidAccept : t -> unit Event.t + val prompt : t -> string option + val set_prompt : t -> string option -> unit + val validationMessage : t -> InputBoxValidationMessage.t or_undefined + val set_validationMessage : t -> InputBoxValidationMessage.t or_undefined -> unit + val show : t -> unit + + val set + : t + -> ?title:string + -> ?ignoreFocusOut:bool + -> ?value:string + -> ?valueSelection:int * int + -> ?placeholder:string + -> ?password:bool + -> ?prompt:string + -> ?validationMessage:InputBoxValidationMessage.t + -> unit + -> t +end + module OpenDialogOptions : sig include Ojs.T @@ -1562,16 +1725,6 @@ module TreeItemLabel : sig val highlights : t -> (int * int) list option end -module ThemeIcon : sig - include Ojs.T - - val make : id:string -> ?color:ThemeColor.t -> unit -> t - val file : t - val folder : t - val id : t -> string - val color : t -> ThemeColor.t option -end - module TreeItem : sig include Ojs.T @@ -1580,15 +1733,6 @@ module TreeItem : sig | `TreeItemLabel of TreeItemLabel.t ] - module LightDarkIcon : sig - type t = - { light : [ `String of string | `Uri of Uri.t ] - ; dark : [ `String of string | `Uri of Uri.t ] - } - - include Ojs.T with type t := t - end - type iconPath = [ `String of string | `Uri of Uri.t @@ -1986,6 +2130,9 @@ module Window : sig -> unit -> 'a option Promise.t + val createQuickPick : 'a Js.t -> unit -> 'a QuickPick.t + val quickInputButtonBack : QuickInputButton.t + val showQuickPick : items:string list -> ?options:QuickPickOptions.t @@ -1999,6 +2146,7 @@ module Window : sig -> unit -> string option Promise.t + val createInputBox : unit -> InputBox.t val showOpenDialog : ?options:OpenDialogOptions.t -> unit -> Uri.t list option Promise.t val createOutputChannel : name:string -> OutputChannel.t diff --git a/src/custom_requests.ml b/src/custom_requests.ml index cb62d125e..d3e27da15 100644 --- a/src/custom_requests.ml +++ b/src/custom_requests.ml @@ -156,3 +156,67 @@ module Merlin_jump = struct let make ~uri ~position = { uri; position } let request = { meth = ocamllsp_prefixed "jump"; encode_params; decode_response } end + +module Type_search = struct + type type_search_result = + { name : string + ; typ : string + ; loc : Range.t + ; doc : MarkupContent.t option + ; cost : int + ; constructible : string + } + + type params = + { uri : Uri.t + ; position : Position.t + ; limit : int + ; query : string + ; with_doc : bool + ; doc_format : MarkupKind.t option + } + + type response = type_search_result list + + let encode_params { uri; position; limit; query; with_doc; doc_format } = + let open Jsonoo.Encode in + let uri = "textDocument", object_ [ "uri", string @@ Uri.toString uri () ] in + let position = "position", Position.json_of_t position in + let query = "query", string query in + let limit = "limit", int limit in + let with_doc = "with_doc", bool with_doc in + let doc_format = + ( "doc_format" + , MarkupKind.json_of_t (Option.value ~default:MarkupKind.Markdown doc_format) ) + in + object_ [ uri; position; query; limit; with_doc; doc_format ] + ;; + + let decode_response response = + let open Jsonoo.Decode in + let decode_res response = + let name = field "name" string response in + let typ = field "typ" string response in + let loc = field "loc" Range.t_of_json response in + let doc = try_optional (field "doc" MarkupContent.t_of_json) response in + let cost = field "cost" int response in + let constructible = field "constructible" string response in + { name; typ; loc; doc; cost; constructible } + in + list decode_res response + ;; + + let make + ~uri + ~position + ~limit + ~query + ~with_doc + ?(doc_format = Some MarkupKind.Markdown) + () + = + { uri; position; limit; query; with_doc; doc_format } + ;; + + let request = { meth = ocamllsp_prefixed "typeSearch"; encode_params; decode_response } +end diff --git a/src/custom_requests.mli b/src/custom_requests.mli index 4263c3c35..3bdbdfe42 100644 --- a/src/custom_requests.mli +++ b/src/custom_requests.mli @@ -64,3 +64,29 @@ module Merlin_jump : sig val make : uri:Uri.t -> position:Position.t -> params val request : (params, response) custom_request end + +module Type_search : sig + type type_search_result = + { name : string + ; typ : string + ; loc : Range.t + ; doc : MarkupContent.t option + ; cost : int + ; constructible : string + } + + type params + type response = type_search_result list + + val make + : uri:Uri.t + -> position:Position.t + -> limit:int + -> query:string + -> with_doc:bool + -> ?doc_format:MarkupKind.t option + -> unit + -> params + + val request : (params, response) custom_request +end diff --git a/src/extension_commands.ml b/src/extension_commands.ml index d0f1795eb..0b658aa96 100644 --- a/src/extension_commands.ml +++ b/src/extension_commands.ml @@ -753,6 +753,203 @@ module MerlinJump = struct ;; end +module Search_by_type = struct + let extension_name = "Search By Type" + + let is_valid_text_doc textdoc = + match TextDocument.languageId textdoc with + | "ocaml" | "ocaml.interface" | "reason" | "ocaml.ocamllex" -> true + | _ -> false + ;; + + let ocaml_lsp_doesnt_support_search_by_type ocaml_lsp = + not (Ocaml_lsp.can_handle_search_by_type ocaml_lsp) + ;; + + let get_search_results ~query ~limit ~with_doc ~position text_editor client = + let doc = TextEditor.document text_editor in + let uri = TextDocument.uri doc in + Custom_requests.( + send_request + client + Type_search.request + (Type_search.make ~uri ~position ~limit ~query ~with_doc ())) + |> Promise.catch ~rejected:(fun _ -> Promise.return []) + ;; + + let input_box = + (* Re-using the same instance of the input box allows us to remember the + last input. *) + let box = + InputBox.set + (Window.createInputBox ()) + ~title:"Search By Type" + ~ignoreFocusOut:false + ~placeholder:"int -> string / -int +string" + ~prompt: + "Perform a search by type request by providing a type signature to look for" + () + in + let _disposable = + InputBox.onDidChangeValue + box + ~listener:(fun _ -> InputBox.set_validationMessage box None) + () + in + box + ;; + + let rec display_search_results query results text_editor position client = + let format_doc (doc : MarkupContent.t option) = + match doc with + | Some doc -> doc.value + | None -> "" + in + let quickPickItems = + List.map results ~f:(fun (res : Custom_requests.Type_search.type_search_result) -> + QuickPickItem.create + ~label:res.name + ~description:res.typ + ~detail:(format_doc res.doc) + ()) + in + let module QuickPick = Vscode.QuickPick.Make (QuickPickItem) in + let quickPick = + QuickPick.set + (Window.createQuickPick (module QuickPickItem) ()) + ~title:"Type/Polarity Search Results" + ~activeItems:[] + ~busy:false + ~enabled:true + ~placeholder:"Select an item to insert it to the editor" + ~selectedItems:[] + ~ignoreFocusOut:false + ~items:quickPickItems + ~buttons:[ Window.quickInputButtonBack ] + () + in + let _disposable = + QuickPick.onDidTriggerButton + quickPick + ~listener:(fun _ -> show_query_input text_editor client) + () + in + let _disposable = + QuickPick.onDidAccept + quickPick + ~listener:(fun () -> + match QuickPick.selectedItems quickPick with + | Some (item :: _) -> + let value = QuickPickItem.label item in + let _ = + Vscode.TextEditor.edit + text_editor + ~callback:(fun ~editBuilder -> + Vscode.TextEditorEdit.insert editBuilder ~location:position ~value) + () + in + QuickPick.hide quickPick + | _ -> display_search_results query results text_editor position client) + () + in + let _disposable = + QuickPick.onDidHide quickPick ~listener:(fun () -> QuickPick.dispose quickPick) + in + QuickPick.show quickPick + + and show_query_input = + let previous : Disposable.t option ref = ref None in + fun ?(empty_result = false) text_editor client -> + let open Promise.Syntax in + let () = + match !previous with + | None -> () + | Some disposable -> Disposable.dispose disposable + in + let _update_input_box = + let validationMessage = + if empty_result + then + Some + (InputBoxValidationMessage.create + ~message:"No result found. Check the syntax or use a more general query." + ~severity:Warning + ()) + else None + in + InputBox.set_validationMessage input_box validationMessage; + InputBox.set_busy input_box false; + InputBox.set_enabled input_box true + in + let onDidAccept_disposable = + InputBox.onDidAccept + input_box + ~listener:(fun () -> + match InputBox.value input_box with + | Some query -> + let () = InputBox.set_busy input_box true in + let () = InputBox.set_enabled input_box false in + let position = TextEditor.selection text_editor |> Selection.active in + ignore + (let+ query_results = + get_search_results + ~query + ~with_doc:true + ~limit:100 + ~position + text_editor + client + in + match query_results with + | [] -> show_query_input ~empty_result:true text_editor client + | results -> + let results = + List.remove_consecutive_duplicates + ~which_to_keep:`First + ~equal: + (fun + (left : Custom_requests.Type_search.type_search_result) + right -> + String.equal left.name right.name && left.cost = right.cost) + results + in + display_search_results query results text_editor position client) + | None -> ()) + () + in + previous := Some onDidAccept_disposable; + InputBox.show input_box + ;; + + let _search_by_type = + let handler (instance : Extension_instance.t) ~args:_ = + match Window.activeTextEditor () with + | None -> + Extension_consts.Command_errors.text_editor_must_be_active + extension_name + ~expl: + "The cursor position is used to determine the correct environment and insert \ + the result." + |> show_message `Error "%s" + | Some text_editor when not (is_valid_text_doc (TextEditor.document text_editor)) -> + show_message + `Error + "Invalid file type. This command only works in ocaml files, ocaml interface \ + files, reason files or ocamllex files." + | Some text_editor -> + (match Extension_instance.lsp_client instance with + | None -> show_message `Warn "ocamllsp is not running" + | Some (_client, ocaml_lsp) + when ocaml_lsp_doesnt_support_search_by_type ocaml_lsp -> + show_message + `Warn + "The installed version of `ocamllsp` does not support type search" + | Some (client, _) -> show_query_input text_editor client) + in + command Extension_consts.Commands.search_by_type 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 90da2c490..3c311d42a 100644 --- a/src/extension_consts.ml +++ b/src/extension_consts.ml @@ -35,6 +35,7 @@ module Commands = struct let copy_type_under_cursor = ocaml_prefixed "copy-type-under-cursor" let construct = ocaml_prefixed "construct" let merlin_jump = ocaml_prefixed "jump" + let search_by_type = ocaml_prefixed "search-by-type" end module Command_errors = struct diff --git a/src/import.ml b/src/import.ml index 9c78b2088..cdb6586c3 100644 --- a/src/import.ml +++ b/src/import.ml @@ -76,7 +76,7 @@ let show_message kind fmt = match kind with | `Warn -> Window.showWarningMessage ~message () | `Info -> Window.showInformationMessage ~message () - | `Error -> Window.showInformationMessage ~message () + | `Error -> Window.showErrorMessage ~message () in Printf.ksprintf (fun x -> @@ -177,6 +177,40 @@ module Range = struct include Vscode.Range end +module MarkupKind = struct + type t = + | PlainText + | Markdown + + let json_of_t (t : t) : Jsonoo.t = + match t with + | PlainText -> Jsonoo.Encode.string "plaintext" + | Markdown -> Jsonoo.Encode.string "markdown" + ;; + + let t_of_json (json : Jsonoo.t) : t = + match Jsonoo.Decode.string json with + | "plaintext" -> PlainText + | "markdown" -> Markdown + (* Default to plaintext *) + | _ -> PlainText + ;; +end + +module MarkupContent = struct + type t = + { kind : MarkupKind.t + ; value : string + } + + let t_of_json json = + let open Jsonoo.Decode in + let kind = field "kind" MarkupKind.t_of_json json in + let value = field "value" string json in + { kind; value } + ;; +end + module Promise = struct include Promise diff --git a/src/ocaml_lsp.ml b/src/ocaml_lsp.ml index 2ec3baf10..cda1f1477 100644 --- a/src/ocaml_lsp.ml +++ b/src/ocaml_lsp.ml @@ -42,6 +42,7 @@ module Experimental_capabilities = struct ; handleTypeEnclosing : bool ; handleConstruct : bool ; handleJump : bool + ; handleSearchByType : bool } let default = @@ -51,6 +52,7 @@ module Experimental_capabilities = struct ; handleTypeEnclosing = false ; handleConstruct = false ; handleJump = false + ; handleSearchByType = false } ;; @@ -65,6 +67,7 @@ module Experimental_capabilities = struct let handleInferIntf = has_capability "handleInferIntf" in let handleTypedHoles = has_capability "handleTypedHoles" in let handleTypeEnclosing = has_capability "handleTypeEnclosing" in + let handleSearchByType = has_capability "handleTypeSearch" in let handleConstruct = has_capability "handleConstruct" in let handleJump = has_capability "handleJump" in { handleSwitchImplIntf @@ -73,6 +76,7 @@ module Experimental_capabilities = struct ; handleTypeEnclosing ; handleConstruct ; handleJump + ; handleSearchByType } with | Jsonoo.Decode_error err -> @@ -238,3 +242,4 @@ let can_handle_typed_holes t = t.experimental_capabilities.handleTypedHoles let can_handle_type_enclosing 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 b063e393b..afecac1df 100644 --- a/src/ocaml_lsp.mli +++ b/src/ocaml_lsp.mli @@ -10,6 +10,7 @@ val can_handle_typed_holes : t -> bool val can_handle_type_enclosing : t -> bool val can_handle_construct : t -> bool val can_handle_merlin_jump : t -> bool +val can_handle_search_by_type : t -> bool module OcamllspSettingEnable : sig include Ojs.T diff --git a/src/treeview_commands.ml b/src/treeview_commands.ml index aede34816..66ab4f187 100644 --- a/src/treeview_commands.ml +++ b/src/treeview_commands.ml @@ -1,7 +1,7 @@ let select_sandbox_item = let icon = `LightDark - Vscode.TreeItem.LightDarkIcon. + Vscode.LightDarkIcon. { light = `String (Path.asset "collection-light.svg" |> Path.to_string) ; dark = `String (Path.asset "collection-dark.svg" |> Path.to_string) } @@ -19,7 +19,7 @@ let select_sandbox_item = let terminal_item = let icon = `LightDark - Vscode.TreeItem.LightDarkIcon. + Vscode.LightDarkIcon. { light = `String (Path.asset "terminal-light.svg" |> Path.to_string) ; dark = `String (Path.asset "terminal-dark.svg" |> Path.to_string) } @@ -66,7 +66,28 @@ let jump_item = item ;; -let items = [ select_sandbox_item; terminal_item; construct_item; jump_item ] +let type_search_item = + let icon = `ThemeIcon (Vscode.ThemeIcon.make ~id:"search-view-icon" ()) in + let label = + `TreeItemLabel + (Vscode.TreeItemLabel.create ~label:"Search a value by type or polarity" ()) + in + let item = Vscode.TreeItem.make_label ~label () in + let command = + Vscode.Command.create + ~title:"Search a value by type or polarity" + ~command:"ocaml.search-by-type" + () + in + Vscode.TreeItem.set_iconPath item icon; + Vscode.TreeItem.set_command item command; + item +;; + +let items = + [ select_sandbox_item; terminal_item; construct_item; jump_item; type_search_item ] +;; + let getTreeItem ~element = `Value element let getChildren ?element () = diff --git a/src/treeview_help.ml b/src/treeview_help.ml index a8a60ba18..1ba3a4f86 100644 --- a/src/treeview_help.ml +++ b/src/treeview_help.ml @@ -1,7 +1,7 @@ let discord_item = let icon = `LightDark - Vscode.TreeItem.LightDarkIcon. + Vscode.LightDarkIcon. { light = `String (Path.asset "discord-light.svg" |> Path.to_string) ; dark = `String (Path.asset "discord-dark.svg" |> Path.to_string) } @@ -24,7 +24,7 @@ let discord_item = let discuss_item = let icon = `LightDark - Vscode.TreeItem.LightDarkIcon. + Vscode.LightDarkIcon. { light = `String (Path.asset "chat-light.svg" |> Path.to_string) ; dark = `String (Path.asset "chat-dark.svg" |> Path.to_string) } @@ -49,7 +49,7 @@ let discuss_item = let github_item = let icon = `LightDark - Vscode.TreeItem.LightDarkIcon. + Vscode.LightDarkIcon. { light = `String (Path.asset "github-light.svg" |> Path.to_string) ; dark = `String (Path.asset "github-dark.svg" |> Path.to_string) } diff --git a/src/treeview_sandbox.ml b/src/treeview_sandbox.ml index 84d9fd782..e487e98a3 100644 --- a/src/treeview_sandbox.ml +++ b/src/treeview_sandbox.ml @@ -10,7 +10,7 @@ module Dependency = struct let tooltip t = Sandbox.Package.synopsis t let icon _ = - TreeItem.LightDarkIcon. + LightDarkIcon. { light = `String (Path.asset "number-light.svg" |> Path.to_string) ; dark = `String (Path.asset "number-dark.svg" |> Path.to_string) } diff --git a/src/treeview_switches.ml b/src/treeview_switches.ml index 62ac89b6e..f7a8983ee 100644 --- a/src/treeview_switches.ml +++ b/src/treeview_switches.ml @@ -43,7 +43,7 @@ module Dependency = struct match dependency with | Switch _ -> let selected = if is_current_sandbox then "-selected" else "" in - TreeItem.LightDarkIcon. + LightDarkIcon. { light = `String (Path.asset @@ "dependency-light" ^ selected ^ ".svg" |> Path.to_string) @@ -51,7 +51,7 @@ module Dependency = struct `String (Path.asset @@ "dependency-dark" ^ selected ^ ".svg" |> Path.to_string) } | Package _ -> - TreeItem.LightDarkIcon. + LightDarkIcon. { light = `String (Path.asset "number-light.svg" |> Path.to_string) ; dark = `String (Path.asset "number-dark.svg" |> Path.to_string) }