[B] ocaml#1812 Inlay hint upstreaming

CHANGES.md

@@ -7,6 +7,7 @@ unreleased
     - Add `-unboxed-types` and `-no-unboxed-types` as ocaml ignored flags (#1795, fixes #1794)
     - destruct: Refinement in the presence of optional arguments (#1800 #1807, fixes #1770)
     - Implement new expand-node command for expanding PPX annotations (#1745)
+    - Implement new inlay-hints command for adding hints on a sourcetree (#1812)
   + editor modes
     - vim: fix python-3.12 syntax warnings in merlin.py (#1798)
     - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804)

src/analysis/inlay_hints.ml

@@ -0,0 +1,179 @@
+open Std
+
+let {Logger.log} = Logger.for_section "inlay-hints"
+
+module Iterator = Ocaml_typing.Tast_iterator
+
+let is_ghost_location avoid_ghost loc =
+  loc.Location.loc_ghost && avoid_ghost
+
+let pattern_has_constraint (type a) (pattern: a Typedtree.general_pattern) =
+  List.exists ~f:(fun (extra, _, _) ->
+      match extra with
+      | Typedtree.Tpat_constraint _ -> true
+      | Typedtree.Tpat_type (_, _)
+      | Typedtree.Tpat_open (_, _, _)
+      | Typedtree.Tpat_unpack -> false
+    ) pattern.pat_extra
+
+let structure_iterator
+    hint_let_binding
+    hint_pattern_binding
+    avoid_ghost_location
+    typedtree
+    range
+    callback =
+
+  let case_iterator hint_lhs (iterator : Iterator.iterator) case =
+    let () = log ~title:"case" "on case" in
+    let () =
+      if hint_lhs then
+        iterator.pat iterator case.Typedtree.c_lhs
+    in
+    let () = Option.iter ~f:(iterator.expr iterator) case.c_guard in
+    iterator.expr iterator case.c_rhs
+  in
+
+  let value_binding_iterator hint_lhs (iterator : Iterator.iterator) vb =
+    let () = log ~title:"value_binding" "%a" Logger.fmt (fun fmt ->
+        Format.fprintf fmt "On value binding %a"
+          (Printtyped.pattern 0) vb.Typedtree.vb_pat
+      )
+    in
+    if Location_aux.overlap_with_range range vb.Typedtree.vb_loc then
+      if hint_lhs then
+        let () = log ~title:"value_binding" "overlap" in
+        match vb.vb_expr.exp_desc with
+        | Texp_function _ -> iterator.expr iterator vb.vb_expr
+        | _ -> Iterator.default_iterator.value_binding iterator vb
+      else iterator.expr iterator vb.vb_expr
+  in
+
+  let expr_iterator (iterator : Iterator.iterator) expr =
+    let () = log ~title:"expression" "%a" Logger.fmt (fun fmt ->
+        Format.fprintf fmt "On expression %a"
+          Printtyped.expression expr
+        )
+    in
+    if Location_aux.overlap_with_range range expr.Typedtree.exp_loc then
+      let () = log ~title:"expression" "overlap" in
+      match expr.exp_desc with
+      | Texp_let (_, bindings, body) ->
+        let () = log ~title:"expression" "on let" in
+        let () =
+          List.iter
+            ~f:(value_binding_iterator hint_let_binding iterator)
+            bindings
+        in iterator.expr iterator body
+      | Texp_letop { body; _ } ->
+        let () = log ~title:"expression" "on let-op" in
+        case_iterator hint_let_binding iterator body
+      | Texp_match (expr, cases, _) ->
+        let () = log ~title:"expression" "on match" in
+        let () = iterator.expr iterator expr in
+        List.iter ~f:(case_iterator hint_pattern_binding iterator) cases
+      | Texp_function
+          { arg_label = Optional _
+          ; cases =
+              [ { c_rhs =
+                    { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ }
+                ; _
+                }
+              ]
+          ; _
+          } ->
+        iterator.pat iterator vb_pat;
+        iterator.expr iterator body
+      | _ when is_ghost_location avoid_ghost_location expr.exp_loc ->
+        (* Stop iterating when we see a ghost location to avoid
+           annotating generated code *)
+        log ~title:"ghost" "ghost-location found"
+      | _ -> Iterator.default_iterator.expr iterator expr
+  in
+
+  let structure_item_iterator (iterator : Iterator.iterator) item =
+    if Location_aux.overlap_with_range range item.Typedtree.str_loc then
+      let () = log ~title:"structure_item" "overlap" in
+      match item.str_desc with
+      | Tstr_value (_, bindings) ->
+        List.iter ~f:(fun binding ->
+            expr_iterator iterator binding.Typedtree.vb_expr)
+          bindings
+      | _ when is_ghost_location avoid_ghost_location item.str_loc ->
+        (* Stop iterating when we see a ghost location to avoid
+           annotating generated code *)
+        log ~title:"ghost" "ghost-location found"
+      | _ -> Iterator.default_iterator.structure_item iterator item
+  in
+
+  let pattern_iterator
+      (type a) iterator (pattern : a Typedtree.general_pattern) =
+    let () = log ~title:"pattern" "%a" Logger.fmt (fun fmt ->
+        Format.fprintf fmt "On pattern %a"
+          (Printtyped.pattern 0) pattern
+      )
+    in
+    if Location_aux.overlap_with_range range pattern.pat_loc
+       && not (pattern_has_constraint pattern)
+    then
+      let () = log ~title:"pattern" "overlap" in
+      let () = Iterator.default_iterator.pat iterator pattern in
+      match pattern.pat_desc with
+      | Tpat_var _ when not pattern.pat_loc.loc_ghost ->
+        let () = log ~title:"pattern" "found" in
+        callback pattern.pat_env pattern.pat_type pattern.pat_loc
+      | _ -> log ~title:"pattern" "not a var"
+  in
+
+  let iterator = {
+    Ocaml_typing.Tast_iterator.default_iterator with
+    expr = expr_iterator;
+    structure_item = structure_item_iterator;
+    pat = pattern_iterator;
+    value_binding = value_binding_iterator true
+  }
+  in iterator.structure iterator typedtree
+
+type hint = Lexing.position * string
+
+let create_hint env typ loc =
+  let label =  Printtyp.wrap_printing_env env (fun () ->
+    Format.asprintf "%a" Printtyp.type_scheme typ)
+  in
+  let position = loc.Location.loc_end in
+  (position, label)
+
+let of_structure
+    ~hint_let_binding
+    ~hint_pattern_binding
+    ~avoid_ghost_location
+    ~start
+    ~stop
+    structure =
+  let () = log ~title:"start" "%a" Logger.fmt (fun fmt ->
+      Format.fprintf fmt "Start on %s to %s with : let: %b, pat: %b, ghost: %b"
+        (Lexing.print_position () start)
+        (Lexing.print_position () stop)
+        hint_let_binding
+        hint_pattern_binding
+        avoid_ghost_location)
+  in
+  let range = (start, stop) in
+  let hints = ref [] in
+  let () =
+    structure_iterator
+      hint_let_binding
+      hint_pattern_binding
+      avoid_ghost_location
+      structure
+      range
+      (fun env typ loc ->
+          let () = log ~title:"hint" "Find hint %a" Logger.fmt (fun fmt ->
+            Format.fprintf fmt "%s - %a"
+              (Location_aux.print () loc)
+              (Printtyp.type_expr) typ)
+          in
+          let hint = create_hint env typ loc in
+          hints := hint :: !hints)
+  in
+  !hints

src/analysis/inlay_hints.mli

@@ -0,0 +1,12 @@
+(** Builds the list of inlay hints to be displayed on a document. *)
+
+type hint = Lexing.position * string
+
+val of_structure :
+  hint_let_binding:bool
+  -> hint_pattern_binding:bool
+  -> avoid_ghost_location:bool
+  -> start:Lexing.position
+  -> stop:Lexing.position
+  -> Typedtree.structure
+  -> hint list

src/commands/new_commands.ml

@@ -572,6 +572,52 @@ of the buffer."
     end
   ;
 
+  command "inlay-hints"
+    ~doc:"return a list of inly-hints for additional client (like LSP)"
+    ~spec: [
+      arg "-start" "<position> Where inlay-hints generation start"
+        (marg_position
+           (fun start
+             (_start, stop, let_binding, pattern_binding, ghost) ->
+             (start, stop, let_binding, pattern_binding, ghost)));
+      arg "-end" "<position> Where inlay-hints generation stop"
+        (marg_position
+           (fun stop
+             (start, _stop, let_binding, pattern_binding, ghost) ->
+             (start, stop, let_binding, pattern_binding, ghost)));
+      optional "-let-binding" "<bool> Hint let-binding (default is false)"
+        (Marg.bool
+           (fun let_binding
+             (start, stop, _let_binding, pattern_binding, ghost) ->
+           (start, stop, let_binding, pattern_binding, ghost)));
+      optional
+        "-pattern-binding" "<bool> Hint pattern-binding (default is false)"
+        (Marg.bool
+           (fun pattern_binding
+             (start, stop, let_binding, _pattern_binding, ghost) ->
+           (start, stop, let_binding, pattern_binding, ghost)));
+      optional
+        "-avoid-ghost-location"
+        "<bool> Avoid hinting ghost location (default is true)"
+        (Marg.bool
+           (fun ghost
+             (start, stop, let_binding, pattern_binding, _ghost) ->
+           (start, stop, let_binding, pattern_binding, ghost)));
+    ]
+    ~default:(`None, `None,  false, false, true)
+    begin fun buffer (start, stop, let_binding, pattern_binding, avoid_ghost) ->
+      match (start, stop) with
+      | (`None, `None) -> failwith "-start <pos> and -end are mandatory"
+      | (`None, _) -> failwith "-start <pos> is mandatory"
+      | (_, `None) -> failwith "-end <pos> is mandatory"
+      | (#Msource.position, #Msource.position) as position ->
+        let (start, stop) = position in
+        run buffer
+          (Query_protocol.Inlay_hints
+             (start, stop, let_binding, pattern_binding, avoid_ghost))
+    end
+  ;
+
   command "shape"
 ~doc:"This command can be used to assist navigation in a source code buffer.
 It returns a tree of all relevant locations around the cursor.

src/commands/query_json.ml

@@ -154,6 +154,14 @@ let dump (type a) : a t -> json =
       );
       "depth", `Int depth
     ]
+  | Inlay_hints (start, stop, hint_let_binding, hint_pattern_var, ghost) ->
+    mk "inlay-hints" [
+      "start", mk_position start;
+      "stop", mk_position stop;
+      "hint-let-binding", `Bool hint_let_binding;
+      "hint-pattern-variable", `Bool hint_pattern_var;
+      "avoid-ghost-location", `Bool ghost
+    ]
   | Outline -> mk "outline" []
   | Errors { lexing; parsing; typing } ->
     let args =
@@ -351,6 +359,14 @@ let json_of_locate resp =
   | `Found (Some file,pos) ->
     `Assoc ["file",`String file; "pos", Lexing.json_of_position pos]
 
+let json_of_inlay_hints hints =
+  let json_of_hint (position, label) =
+     `Assoc [
+       "pos", Lexing.json_of_position position;
+       "label", `String label
+     ]
+  in `List (List.map ~f:json_of_hint hints)
+
 let json_of_response (type a) (query : a t) (response : a) : json =
   match query, response with
   | Type_expr _, str -> `String str
@@ -441,6 +457,8 @@ let json_of_response (type a) (query : a t) (response : a) : json =
     `List (json_of_outline outlines)
   | Shape _, shapes ->
     `List (List.map ~f:json_of_shape shapes)
+  | Inlay_hints _, result ->
+    json_of_inlay_hints result
   | Errors _, errors ->
     `List (List.map ~f:json_of_error errors)
   | Dump _, json -> json

src/frontend/query_commands.ml

@@ -860,6 +860,29 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in
     List.sort ~cmp locs
 
+  | Inlay_hints (
+      start,
+      stop,
+      hint_let_binding,
+      hint_pattern_binding,
+      avoid_ghost_location
+    ) ->
+    let start = Mpipeline.get_lexing_pos pipeline start
+    and stop = Mpipeline.get_lexing_pos pipeline stop in
+    let typer_result = Mpipeline.typer_result pipeline in
+    begin match Mtyper.get_typedtree typer_result with
+    | `Interface _ -> []
+    | `Implementation structure ->
+      Inlay_hints.of_structure
+        ~hint_let_binding
+        ~hint_pattern_binding
+        ~avoid_ghost_location
+        ~start
+        ~stop
+        structure
+    end
+
   | Version ->
     Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n"
       Merlin_config.version Sys.ocaml_version;
+

src/frontend/query_protocol.ml

@@ -192,6 +192,9 @@ type _ t =
   | Construct
     : Msource.position * [`None | `Local] option * int option
     -> (Location.t * string list) t
+  | Inlay_hints
+    : Msource.position * Msource.position * bool * bool * bool
+    -> (Lexing.position * string) list t
   | Outline(* *)
     :  outline t
   | Shape(* *)

src/ocaml/parsing/location_aux.ml

@@ -50,6 +50,11 @@ let included ~into:parent_loc child_loc =
 Lexing.compare_pos child_loc.loc_start parent_loc.loc_start >= 0 &&
   Lexing.compare_pos parent_loc.loc_end child_loc.loc_end >= 0
 
+let overlap_with_range (start, stop) loc =
+  let a = Lexing.compare_pos start loc.loc_end
+  and b = Lexing.compare_pos stop loc.loc_start in
+  a <= 0 && b >= 0 || a >= 0 && b <= 0
+
 let union l1 l2 =
   if l1 = Location.none then l2
   else if l2 = Location.none then l1

src/ocaml/parsing/location_aux.mli

@@ -46,6 +46,10 @@ val extend : t -> t -> t
     in [parent]. Otherwise returns [false]. *)
 val included : into:t -> t -> bool
 
+(** [overlap_with_range (pos_start, pos_end) loc] returns [true] if 
+    [loc] overlap with the range defined by [pos_start] and [pos_end]. *)
+val overlap_with_range : (Lexing.position * Lexing.position) -> t -> bool
+
 (** Filter valid errors, log invalid ones *)
 val prepare_errors : exn list -> Location.error list
 

src/ocaml/typing/printtyped.ml

@@ -975,3 +975,5 @@ let implementation ppf x = list 0 structure_item ppf x.str_items;;
 
 let implementation_with_coercion ppf Typedtree.{structure; _} =
   implementation ppf structure
+
+let expression ppf x = expression 0 ppf x

src/ocaml/typing/printtyped.mli

@@ -24,3 +24,4 @@ val implementation_with_coercion :
 
 (* Added by merlin for debugging purposes *)
 val pattern : int -> formatter -> _ general_pattern -> unit
+val expression : formatter -> expression -> unit

src/utils/std.ml

@@ -392,6 +392,7 @@ module String = struct
 
   (* Drop characters from beginning of string *)
   let drop n s = sub s ~pos:n ~len:(length s - n)
+
 
   module Set = struct
     include MoreLabels.Set.Make (struct type t = string let compare = compare end)