New command: Type of dynamic selection (#1675)

* 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.

* Add changelog entry for #1675

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)

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": [

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])

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

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

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 }
   ;;