Skip to content

Commit

Permalink
add config options for pattern variables and let bindings
Browse files Browse the repository at this point in the history
  • Loading branch information
@jfeser
jfeser committed Jul 17, 2023
1 parent 062952a commit fc560ed
Show file tree
Hide file tree
Showing 2 changed files with 183 additions and 12 deletions.
140 changes: 137 additions & 3 deletions ocaml-lsp-server/src/config_data.ml
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,106 @@
open Import
open Import.Json.Conv

module InlayHints = struct
type t =
{ hint_pattern_variables : bool
[@key "hintPatternVariables"] [@default false]
; hint_let_bindings : bool [@key "hintLetBindings"] [@default false]
}
[@@deriving_inline yojson] [@@yojson.allow_extra_fields]

let _ = fun (_ : t) -> ()


let t_of_yojson =
(let _tp_loc = "ocaml-lsp-server/src/config_data.ml.InlayHints.t" in
function
| `Assoc field_yojsons as yojson ->
let hint_pattern_variables_field = ref Ppx_yojson_conv_lib.Option.None
and hint_let_bindings_field = ref Ppx_yojson_conv_lib.Option.None
and duplicates = ref []
and extra = ref [] in
let rec iter =
function
| (field_name, _field_yojson)::tail ->
((match field_name with
| "hintPatternVariables" ->
(match Ppx_yojson_conv_lib.(!)
hint_pattern_variables_field
with
| Ppx_yojson_conv_lib.Option.None ->
let fvalue = bool_of_yojson _field_yojson in
hint_pattern_variables_field :=
(Ppx_yojson_conv_lib.Option.Some fvalue)
| Ppx_yojson_conv_lib.Option.Some _ ->
duplicates := (field_name ::
(Ppx_yojson_conv_lib.(!) duplicates)))
| "hintLetBindings" ->
(match Ppx_yojson_conv_lib.(!) hint_let_bindings_field
with
| Ppx_yojson_conv_lib.Option.None ->
let fvalue = bool_of_yojson _field_yojson in
hint_let_bindings_field :=
(Ppx_yojson_conv_lib.Option.Some fvalue)
| Ppx_yojson_conv_lib.Option.Some _ ->
duplicates := (field_name ::
(Ppx_yojson_conv_lib.(!) duplicates)))
| _ -> ());
iter tail)
| [] -> () in
(iter field_yojsons;
(match Ppx_yojson_conv_lib.(!) duplicates with
| _::_ ->
Ppx_yojson_conv_lib.Yojson_conv_error.record_duplicate_fields
_tp_loc (Ppx_yojson_conv_lib.(!) duplicates) yojson
| [] ->
(match Ppx_yojson_conv_lib.(!) extra with
| _::_ ->
Ppx_yojson_conv_lib.Yojson_conv_error.record_extra_fields
_tp_loc (Ppx_yojson_conv_lib.(!) extra) yojson
| [] ->
let (hint_pattern_variables_value, hint_let_bindings_value)
=
((Ppx_yojson_conv_lib.(!) hint_pattern_variables_field),
(Ppx_yojson_conv_lib.(!) hint_let_bindings_field)) in
{
hint_pattern_variables =
((match hint_pattern_variables_value with
| Ppx_yojson_conv_lib.Option.None -> false
| Ppx_yojson_conv_lib.Option.Some v -> v));
hint_let_bindings =
((match hint_let_bindings_value with
| Ppx_yojson_conv_lib.Option.None -> false
| Ppx_yojson_conv_lib.Option.Some v -> v))
})))
| _ as yojson ->
Ppx_yojson_conv_lib.Yojson_conv_error.record_list_instead_atom _tp_loc
yojson : Ppx_yojson_conv_lib.Yojson.Safe.t -> t)

let _ = t_of_yojson

let yojson_of_t =
(function
| { hint_pattern_variables = v_hint_pattern_variables
; hint_let_bindings = v_hint_let_bindings
} ->
let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in
let bnds =
let arg = yojson_of_bool v_hint_let_bindings in
("hintLetBindings", arg) :: bnds
in
let bnds =
let arg = yojson_of_bool v_hint_pattern_variables in
("hintPatternVariables", arg) :: bnds
in
`Assoc bnds
: t -> Ppx_yojson_conv_lib.Yojson.Safe.t)

let _ = yojson_of_t

[@@@end]
end

module Lens = struct
type t = { enable : bool [@default true] }
[@@deriving_inline yojson] [@@yojson.allow_extra_fields]
Expand Down Expand Up @@ -150,6 +250,8 @@ type t =
[@default None] [@yojson_drop_default ( = )]
; extended_hover : ExtendedHover.t Json.Nullable_option.t
[@key "extendedHover"] [@default None] [@yojson_drop_default ( = )]
; inlay_hints : InlayHints.t Json.Nullable_option.t
[@key "inlayHints"] [@default None] [@yojson_drop_default ( = )]
}
[@@deriving_inline yojson] [@@yojson.allow_extra_fields]

Expand All @@ -161,6 +263,7 @@ let t_of_yojson =
| `Assoc field_yojsons as yojson -> (
let codelens_field = ref Ppx_yojson_conv_lib.Option.None
and extended_hover_field = ref Ppx_yojson_conv_lib.Option.None
and inlay_hints_field = ref Ppx_yojson_conv_lib.Option.None
and duplicates = ref []
and extra = ref [] in
let rec iter = function
Expand All @@ -186,6 +289,17 @@ let t_of_yojson =
extended_hover_field := Ppx_yojson_conv_lib.Option.Some fvalue
| Ppx_yojson_conv_lib.Option.Some _ ->
duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates)
| "inlayHints" -> (
match Ppx_yojson_conv_lib.( ! ) inlay_hints_field with
| Ppx_yojson_conv_lib.Option.None ->
let fvalue =
Json.Nullable_option.t_of_yojson
InlayHints.t_of_yojson
_field_yojson
in
inlay_hints_field := Ppx_yojson_conv_lib.Option.Some fvalue
| Ppx_yojson_conv_lib.Option.Some _ ->
duplicates := field_name :: Ppx_yojson_conv_lib.( ! ) duplicates)
| _ -> ());
iter tail
| [] -> ()
Expand All @@ -205,9 +319,10 @@ let t_of_yojson =
(Ppx_yojson_conv_lib.( ! ) extra)
yojson
| [] ->
let codelens_value, extended_hover_value =
let codelens_value, extended_hover_value, inlay_hints_value =
( Ppx_yojson_conv_lib.( ! ) codelens_field
, Ppx_yojson_conv_lib.( ! ) extended_hover_field )
, Ppx_yojson_conv_lib.( ! ) extended_hover_field
, Ppx_yojson_conv_lib.( ! ) inlay_hints_field )
in
{ codelens =
(match codelens_value with
Expand All @@ -217,6 +332,10 @@ let t_of_yojson =
(match extended_hover_value with
| Ppx_yojson_conv_lib.Option.None -> None
| Ppx_yojson_conv_lib.Option.Some v -> v)
; inlay_hints =
(match inlay_hints_value with
| Ppx_yojson_conv_lib.Option.None -> None
| Ppx_yojson_conv_lib.Option.Some v -> v)
}))
| _ as yojson ->
Ppx_yojson_conv_lib.Yojson_conv_error.record_list_instead_atom
Expand All @@ -228,8 +347,21 @@ let _ = t_of_yojson

let yojson_of_t =
(function
| { codelens = v_codelens; extended_hover = v_extended_hover } ->
| { codelens = v_codelens
; extended_hover = v_extended_hover
; inlay_hints = v_inlay_hints
} ->
let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in
let bnds =
if None = v_inlay_hints then bnds
else
let arg =
(Json.Nullable_option.yojson_of_t InlayHints.yojson_of_t)
v_inlay_hints
in
let bnd = ("inlayHints", arg) in
bnd :: bnds
in
let bnds =
if None = v_extended_hover then bnds
else
Expand Down Expand Up @@ -259,4 +391,6 @@ let _ = yojson_of_t
let default =
{ codelens = Some { enable = false }
; extended_hover = Some { enable = false }
; inlay_hints =
Some { hint_pattern_variables = true; hint_let_bindings = true }
}
55 changes: 46 additions & 9 deletions ocaml-lsp-server/src/inlay_hints.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,8 +14,26 @@ let outline_type ~env typ =
| _ -> true)
|> String.concat ~sep:" "

let hint_binding_iter typedtree range k =
let hint_binding_iter ?(hint_let_bindings = false)
?(hint_pattern_variables = false) typedtree range k =
let module I = Ocaml_typing.Tast_iterator in
(* to be used for pattern variables in match cases, but not for function
arguments *)
let case hint_lhs (iter : I.iterator) (case : _ Typedtree.case) =
if hint_lhs then iter.pat iter case.c_lhs;
Option.iter case.c_guard ~f:(iter.expr iter);
iter.expr iter case.c_rhs
in
let value_binding hint_lhs (iter : I.iterator) (vb : Typedtree.value_binding)
=
if range_overlaps_loc range vb.vb_loc then
if not hint_lhs then iter.expr iter vb.vb_expr
else
match vb.vb_expr.exp_desc with
| Texp_function _ -> iter.expr iter vb.vb_expr
| _ -> I.default_iterator.value_binding iter vb
in

let expr (iter : I.iterator) (e : Typedtree.expression) =
if range_overlaps_loc range e.exp_loc then
match e.exp_desc with
Expand All @@ -31,19 +49,20 @@ let hint_binding_iter typedtree range k =
} ->
iter.pat iter vb_pat;
iter.expr iter body
| Texp_let (_, vbs, body) ->
List.iter vbs ~f:(value_binding hint_let_bindings iter);
iter.expr iter body
| Texp_letop { body; _ } -> case hint_let_bindings iter body
| Texp_match (expr, cases, _) ->
iter.expr iter expr;
List.iter cases ~f:(case hint_pattern_variables iter)
| _ -> I.default_iterator.expr iter e
in

let structure_item (iter : I.iterator) (item : Typedtree.structure_item) =
if range_overlaps_loc range item.str_loc then
I.default_iterator.structure_item iter item
in
let value_binding (iter : I.iterator) (vb : Typedtree.value_binding) =
if range_overlaps_loc range vb.vb_loc then
match vb.vb_expr.exp_desc with
| Texp_function _ -> iter.expr iter vb.vb_expr
| _ -> I.default_iterator.value_binding iter vb
in
let pat (type k) iter (pat : k Typedtree.general_pattern) =
if range_overlaps_loc range pat.pat_loc then
let has_constraint =
Expand All @@ -60,14 +79,27 @@ let hint_binding_iter typedtree range k =
| _ -> ())
in
let iterator =
{ I.default_iterator with expr; structure_item; pat; value_binding }
{ I.default_iterator with
expr
; structure_item
; pat
; value_binding = value_binding true
}
in
iterator.structure iterator typedtree

let compute (state : State.t)
{ InlayHintParams.range; textDocument = { uri }; _ } =
let store = state.store in
let doc = Document_store.get store uri in
let hint_let_bindings =
Option.map state.configuration.data.inlay_hints ~f:(fun c ->
c.hint_let_bindings)
in
let hint_pattern_variables =
Option.map state.configuration.data.inlay_hints ~f:(fun c ->
c.hint_pattern_variables)
in
match Document.kind doc with
| `Other -> Fiber.return None
| `Merlin m when Document.Merlin.kind m = Intf -> Fiber.return None
Expand All @@ -78,7 +110,12 @@ let compute (state : State.t)
match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with
| `Interface _ -> ()
| `Implementation typedtree ->
hint_binding_iter typedtree range (fun env type_ loc ->
hint_binding_iter
?hint_let_bindings
?hint_pattern_variables
typedtree
range
(fun env type_ loc ->
let open Option.O in
let hint =
let label = outline_type ~env type_ in
Expand Down

0 comments on commit fc560ed

Please sign in to comment.