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.
ocamllabs · Dec 12, 2024 · dbb98d1 · dbb98d1
1 parent 1d1fd87
commit dbb98d1
Show file tree

Hide file tree

Showing 16 changed files with 600 additions and 63 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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 :