Inlay hint upstreaming

src/analysis/inlay_hints.ml

@@ -0,0 +1,183 @@
+open Std
+
+let {Logger.log} = Logger.for_section "inlay-hints"
+
+module Iterator = Ocaml_typing.Tast_iterator
+
+let overlap_with_loc (start, stop) loc =
+  let a = Lexing.compare_pos start loc.Location.loc_end
+  and b = Lexing.compare_pos stop loc.Location.loc_start in
+  a <= 0 && b >= 0 || a >= 0 && b <= 0
+
+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 overlap_with_loc 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 overlap_with_loc 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 (_, Tfunction_cases {cases = [
+          { c_rhs = { exp_desc = Texp_let (_, [ {vb_pat; _} ], body); _ }; _ }
+        ]; _}) ->
+        let () = log ~title:"expression" "on function" in
+        let () = iterator.pat iterator vb_pat in
+        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 overlap_with_loc 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 overlap_with_loc 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 run
+    ~hint_let_binding
+    ~hint_pattern_binding
+    ~avoid_ghost_location
+    ~start
+    ~stop
+    pipeline =
+  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 typer_result = Mpipeline.typer_result pipeline in
+  match Mtyper.get_typedtree typer_result with
+  | `Interface _ -> []
+  | `Implementation structure ->
+    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 run :
+  hint_let_binding:bool
+  -> hint_pattern_binding:bool
+  -> avoid_ghost_location:bool
+  -> start:Lexing.position
+  -> stop:Lexing.position
+  -> Mpipeline.t
+  -> 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

@@ -825,6 +825,24 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     in
     locs, status
 
+  | 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
+    Inlay_hints.run
+      ~hint_let_binding
+      ~hint_pattern_binding
+      ~avoid_ghost_location
+      ~start
+      ~stop
+      pipeline
+
   | Version ->
     Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n"
       Merlin_config.version Sys.ocaml_version;
+

src/frontend/query_protocol.ml

@@ -199,6 +199,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/utils/std.ml

@@ -398,6 +398,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)