diff --git a/CHANGES.md b/CHANGES.md index 030b9455b..6777c1a59 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -36,6 +36,7 @@ - Add mark/remove unused actions for open, types, for loop indexes, modules, match cases, rec, and constructors (#1141) +- Add inlay hints for types on let bindings (#1159) - Offer auto-completion for the keyword `in` (#1217) diff --git a/ocaml-lsp-server/src/config_data.ml b/ocaml-lsp-server/src/config_data.ml index 000e63985..1098fc679 100644 --- a/ocaml-lsp-server/src/config_data.ml +++ b/ocaml-lsp-server/src/config_data.ml @@ -1,6 +1,104 @@ 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] @@ -222,6 +320,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 ( = )] ; dune_diagnostics : DuneDiagnostics.t Json.Nullable_option.t [@key "duneDiagnostics"] [@default None] [@yojson_drop_default ( = )] } @@ -235,6 +335,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 dune_diagnostics_field = ref Ppx_yojson_conv_lib.Option.None and duplicates = ref [] and extra = ref [] in @@ -261,6 +362,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) | "duneDiagnostics" -> ( match Ppx_yojson_conv_lib.( ! ) dune_diagnostics_field with | Ppx_yojson_conv_lib.Option.None -> @@ -291,9 +403,13 @@ let t_of_yojson = (Ppx_yojson_conv_lib.( ! ) extra) yojson | [] -> - let codelens_value, extended_hover_value, dune_diagnostics_value = + let ( codelens_value + , extended_hover_value + , inlay_hints_value + , dune_diagnostics_value ) = ( Ppx_yojson_conv_lib.( ! ) codelens_field , Ppx_yojson_conv_lib.( ! ) extended_hover_field + , Ppx_yojson_conv_lib.( ! ) inlay_hints_field , Ppx_yojson_conv_lib.( ! ) dune_diagnostics_field ) in { codelens = @@ -304,6 +420,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) ; dune_diagnostics = (match dune_diagnostics_value with | Ppx_yojson_conv_lib.Option.None -> None @@ -321,6 +441,7 @@ let yojson_of_t = (function | { codelens = v_codelens ; extended_hover = v_extended_hover + ; inlay_hints = v_inlay_hints ; dune_diagnostics = v_dune_diagnostics } -> let bnds : (string * Ppx_yojson_conv_lib.Yojson.Safe.t) list = [] in @@ -334,6 +455,16 @@ let yojson_of_t = let bnd = ("duneDiagnostics", arg) in bnd :: bnds 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 @@ -363,5 +494,7 @@ let _ = yojson_of_t let default = { codelens = Some { enable = false } ; extended_hover = Some { enable = false } + ; inlay_hints = + Some { hint_pattern_variables = false; hint_let_bindings = false } ; dune_diagnostics = Some { enable = true } } diff --git a/ocaml-lsp-server/src/import.ml b/ocaml-lsp-server/src/import.ml index 4f621eb83..0e556c42b 100644 --- a/ocaml-lsp-server/src/import.ml +++ b/ocaml-lsp-server/src/import.ml @@ -234,6 +234,9 @@ include struct module FoldingRangeParams = FoldingRangeParams module Hover = Hover module HoverParams = HoverParams + module InlayHint = InlayHint + module InlayHintKind = InlayHintKind + module InlayHintParams = InlayHintParams module InitializeParams = InitializeParams module InitializeResult = InitializeResult module Location = Location diff --git a/ocaml-lsp-server/src/inlay_hints.ml b/ocaml-lsp-server/src/inlay_hints.ml new file mode 100644 index 000000000..ab7ba1baf --- /dev/null +++ b/ocaml-lsp-server/src/inlay_hints.ml @@ -0,0 +1,137 @@ +open Import +open Fiber.O + +let range_overlaps_loc range loc = + match Range.of_loc_opt loc with + | Some range' -> Range.overlaps range range' + | None -> false + +let outline_type ~env typ = + Ocaml_typing.Printtyp.wrap_printing_env env (fun () -> + Format.asprintf "@[: %a@]" Ocaml_typing.Printtyp.type_scheme typ) + |> String.extract_words ~is_word_char:(function + | ' ' | '\t' | '\n' -> false + | _ -> true) + |> String.concat ~sep:" " + +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 + | Texp_function + { arg_label = Optional _ + ; cases = + [ { c_rhs = + { exp_desc = Texp_let (_, [ { vb_pat; _ } ], body); _ } + ; _ + } + ] + ; _ + } -> + 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 + match item.str_desc with + | Typedtree.Tstr_value (_, vbs) -> + List.iter vbs ~f:(fun (vb : Typedtree.value_binding) -> + expr iter vb.vb_expr) + | _ -> I.default_iterator.structure_item iter item + in + let pat (type k) iter (pat : k Typedtree.general_pattern) = + if range_overlaps_loc range pat.pat_loc then + let has_constraint = + List.exists pat.pat_extra ~f:(fun (extra, _, _) -> + match extra with + | Typedtree.Tpat_constraint _ -> true + | _ -> false) + in + if not has_constraint then ( + I.default_iterator.pat iter pat; + match pat.pat_desc with + | Tpat_var _ when not pat.pat_loc.loc_ghost -> + k pat.pat_env pat.pat_type pat.pat_loc + | _ -> ()) + in + let iterator = + { 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 + | `Merlin doc -> + let hints = ref [] in + let* () = + Document.Merlin.with_pipeline_exn doc (fun pipeline -> + match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with + | `Interface _ -> () + | `Implementation typedtree -> + 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 + let+ position = Position.of_lexical_position loc.loc_end in + InlayHint.create + ~kind:Type + ~position + ~label:(`String label) + ~paddingLeft:false + ~paddingRight:false + () + in + Option.iter hint ~f:(fun hint -> hints := hint :: !hints))) + in + Fiber.return (Some !hints) diff --git a/ocaml-lsp-server/src/inlay_hints.mli b/ocaml-lsp-server/src/inlay_hints.mli new file mode 100644 index 000000000..be8c76265 --- /dev/null +++ b/ocaml-lsp-server/src/inlay_hints.mli @@ -0,0 +1,3 @@ +open Import + +val compute : State.t -> InlayHintParams.t -> InlayHint.t list option Fiber.t diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index a734224fa..f831f6734 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/ocaml-lsp-server/src/ocaml_lsp_server.ml @@ -1,6 +1,7 @@ open Import module Version = Version module Diagnostics = Diagnostics +module Position = Position module Doc_to_md = Doc_to_md module Diff = Diff module Testing = Testing @@ -152,6 +153,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : ~semanticTokensProvider ~experimental ~renameProvider + ~inlayHintProvider:(`Bool true) ~workspace ~executeCommandProvider ?positionEncoding @@ -591,7 +593,8 @@ let on_request : Compl.resolve doc ci resolve Document.Merlin.doc_comment ~markdown)) () | CodeAction params -> Code_actions.compute server params - | InlayHint _ -> now None + | InlayHint params -> + later (fun state () -> Inlay_hints.compute state params) () | TextDocumentColor _ -> now [] | TextDocumentColorPresentation _ -> now [] | TextDocumentHover req -> diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.mli b/ocaml-lsp-server/src/ocaml_lsp_server.mli index 9fa5c0ce7..76b9d6eba 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.mli +++ b/ocaml-lsp-server/src/ocaml_lsp_server.mli @@ -2,5 +2,6 @@ val run : Lsp.Cli.Channel.t -> read_dot_merlin:bool -> unit -> unit module Diagnostics = Diagnostics module Version = Version +module Position = Position module Doc_to_md = Doc_to_md module Testing = Testing diff --git a/ocaml-lsp-server/src/range.ml b/ocaml-lsp-server/src/range.ml index ebcc87d8d..fe3f27cfb 100644 --- a/ocaml-lsp-server/src/range.ml +++ b/ocaml-lsp-server/src/range.ml @@ -57,3 +57,9 @@ let resize_for_edit { TextEdit.range; newText } = { Position.line; character } in { range with end_ } + +let overlaps x y = + let open Ordering in + match (Position.compare x.start y.end_, Position.compare x.end_ y.start) with + | (Lt | Eq), (Gt | Eq) | (Gt | Eq), (Lt | Eq) -> true + | _ -> false diff --git a/ocaml-lsp-server/src/range.mli b/ocaml-lsp-server/src/range.mli index a377c59e7..11edb9489 100644 --- a/ocaml-lsp-server/src/range.mli +++ b/ocaml-lsp-server/src/range.mli @@ -26,3 +26,6 @@ val of_loc : Loc.t -> t less characters than [edit.range], the new range is shrunk to fit [edit.newText] only. *) val resize_for_edit : TextEdit.t -> t + +(** [overlaps r1 r2] is true if [r1] and [r2] overlap. *) +val overlaps : t -> t -> bool diff --git a/ocaml-lsp-server/test/e2e-new/code_actions.ml b/ocaml-lsp-server/test/e2e-new/code_actions.ml index 1779db897..def90b54c 100644 --- a/ocaml-lsp-server/test/e2e-new/code_actions.ml +++ b/ocaml-lsp-server/test/e2e-new/code_actions.ml @@ -517,7 +517,7 @@ let f (x : t) = x |ocaml} in let uri = DocumentUri.of_path "foo.ml" in - let prep client = open_document ~client ~uri ~source:impl_source in + let prep client = Test.openDocument ~client ~uri ~source:impl_source in let intf_source = "" in let range = let start = Position.create ~line:0 ~character:0 in @@ -590,38 +590,6 @@ let parse_selection src = in (src', Range.create ~start ~end_) -let offset_of_position src (pos : Position.t) = - let line_offset = - String.split_lines src |> List.take pos.line - |> List.fold_left ~init:0 ~f:(fun s l -> s + String.length l) - in - line_offset + pos.line (* account for line endings *) + pos.character - -let apply_edits src edits = - let rec apply src = function - | [] -> src - | (new_text, start, end_) :: edits -> - (* apply edit *) - let src' = String.take src start ^ new_text ^ String.drop src end_ in - - (* calculate amount of text added (or removed) *) - let diff_len = String.length new_text - (end_ - start) in - - (* offset positions of remaining edits *) - let edits' = - List.map edits ~f:(fun (new_text, start, end_) -> - (new_text, start + diff_len, end_ + diff_len)) - in - apply src' edits' - in - let edits = - List.map edits ~f:(fun (e : TextEdit.t) -> - ( e.newText - , offset_of_position src e.range.start - , offset_of_position src e.range.end_ )) - in - apply src edits - let apply_code_action ?diagnostics title source range = let open Option.O in (* collect code action results *) @@ -645,7 +613,7 @@ let apply_code_action ?diagnostics title source range = TextEdit.create ~newText:a.newText ~range:a.range | `TextEdit e -> e) | `CreateFile _ | `DeleteFile _ | `RenameFile _ -> []) - |> apply_edits source + |> Test.apply_edits source let code_action_test ~title source = let src, range = parse_selection source in diff --git a/ocaml-lsp-server/test/e2e-new/dune b/ocaml-lsp-server/test/e2e-new/dune index 130105b7d..4ce8ca390 100644 --- a/ocaml-lsp-server/test/e2e-new/dune +++ b/ocaml-lsp-server/test/e2e-new/dune @@ -21,11 +21,11 @@ ppx_yojson_conv_lib lev_fiber lev + ocaml_lsp_server spawn jsonrpc lsp lsp_fiber - ocaml_lsp_server ;; This is because of the (implicit_transitive_deps false) ;; in dune-project base @@ -52,6 +52,7 @@ document_flow for_ppx hover_extended + inlay_hints metrics semantic_hl_data semantic_hl_helpers diff --git a/ocaml-lsp-server/test/e2e-new/inlay_hints.ml b/ocaml-lsp-server/test/e2e-new/inlay_hints.ml new file mode 100644 index 000000000..ad3ae7843 --- /dev/null +++ b/ocaml-lsp-server/test/e2e-new/inlay_hints.ml @@ -0,0 +1,95 @@ +open Test.Import + +let apply_inlay_hints ?(path = "foo.ml") ?range + ?(hint_pattern_variables = false) ?(hint_let_bindings = false) ~source () = + let range = + match range with + | Some r -> r + | None -> + let end_pos = + let lines = String.split source ~on:'\n' in + let last_line = Option.value_exn (List.last lines) in + Position.create + ~line:(List.length lines - 1) + ~character:(String.length last_line) + in + Range.create ~start:(Position.create ~character:0 ~line:0) ~end_:end_pos + in + + let uri = DocumentUri.of_path path in + let request = + let textDocument = TextDocumentIdentifier.create ~uri in + InlayHintParams.create ~textDocument ~range () + in + let inlay_hints = + Test.run_request + ~prep:(fun client -> Test.openDocument ~client ~uri ~source) + ~settings: + (`Assoc + [ ( "inlayHints" + , `Assoc + [ ("hintPatternVariables", `Bool hint_pattern_variables) + ; ("hintLetBindings", `Bool hint_let_bindings) + ] ) + ]) + (InlayHint request) + in + match inlay_hints with + | Some hints -> + let text_edits = + List.map hints ~f:(fun (hint : InlayHint.t) -> + let paddingLeftStr = + match hint.paddingLeft with + | Some true -> "_$" + | None | Some false -> "$" + in + let paddingRightStr = + match hint.paddingRight with + | Some true -> "$_" + | None | Some false -> "$" + in + + let newText = + match hint.label with + | `String s -> paddingLeftStr ^ s ^ paddingRightStr + | `List _ -> failwith "TODO: implement list hints" + in + TextEdit.create + ~range:(Range.create ~start:hint.position ~end_:hint.position) + ~newText) + in + Test.apply_edits source text_edits |> print_endline + | None -> print_endline "No hints found" + +let%expect_test "optional argument" = + apply_inlay_hints ~source:"let f ?x () = x" (); + [%expect {| let f ?x$: 'a option$ () = x |}] + +let%expect_test "optional argument with value" = + apply_inlay_hints ~source:"let f ?(x = 1) () = x" (); + [%expect {| let f ?(x$: int$ = 1) () = x |}] + +let%expect_test "labeled argument" = + apply_inlay_hints ~source:"let f ~x = x + 1" (); + [%expect {| let f ~x$: int$ = x + 1 |}] + +let%expect_test "case argument" = + apply_inlay_hints ~source:"let f (Some x) = x + 1" (); + [%expect {| let f (Some x$: int$) = x + 1 |}] + +let%expect_test "pattern variables" = + let source = "let f x = match x with Some x -> x | None -> 0" in + apply_inlay_hints ~source (); + [%expect {| let f x$: int option$ = match x with Some x -> x | None -> 0 |}]; + + apply_inlay_hints ~hint_pattern_variables:true ~source (); + [%expect + {| let f x$: int option$ = match x with Some x$: int$ -> x | None -> 0 |}] + +let%expect_test "let bindings" = + let source = "let f () = let y = 0 in y" in + apply_inlay_hints ~source (); + [%expect {| let f () = let y = 0 in y |}]; + + apply_inlay_hints ~hint_let_bindings:true ~source (); + [%expect {| let f () = let y$: int$ = 0 in y |}] diff --git a/ocaml-lsp-server/test/e2e-new/start_stop.ml b/ocaml-lsp-server/test/e2e-new/start_stop.ml index 03f6fb237..c9f822580 100644 --- a/ocaml-lsp-server/test/e2e-new/start_stop.ml +++ b/ocaml-lsp-server/test/e2e-new/start_stop.ml @@ -95,6 +95,7 @@ let%expect_test "start/stop" = }, "foldingRangeProvider": true, "hoverProvider": true, + "inlayHintProvider": true, "referencesProvider": true, "renameProvider": { "prepareProvider": true }, "selectionRangeProvider": true, diff --git a/ocaml-lsp-server/test/e2e-new/test.ml b/ocaml-lsp-server/test/e2e-new/test.ml index 313117fe3..359e753a9 100644 --- a/ocaml-lsp-server/test/e2e-new/test.ml +++ b/ocaml-lsp-server/test/e2e-new/test.ml @@ -64,6 +64,7 @@ module Import = struct module Client = Lsp_fiber.Client include Lsp.Types module Uri = Lsp.Uri + module Position = Ocaml_lsp_server.Position end open Import @@ -153,3 +154,93 @@ end = struct end include T + +let run_request ?(prep = fun _ -> Fiber.return ()) ?settings request = + let diagnostics = Fiber.Ivar.create () in + let handler = + Client.Handler.make + ~on_notification:(fun _ -> function + | PublishDiagnostics _ -> ( + let* diag = Fiber.Ivar.peek diagnostics in + match diag with + | Some _ -> Fiber.return () + | None -> Fiber.Ivar.fill diagnostics ()) + | _ -> Fiber.return ()) + () + in + run ~handler @@ fun client -> + let run_client () = + let capabilities = + let window = + let showDocument = + ShowDocumentClientCapabilities.create ~support:true + in + WindowClientCapabilities.create ~showDocument () + in + ClientCapabilities.create ~window () + in + Client.start client (InitializeParams.create ~capabilities ()) + in + let run = + let* (_ : InitializeResult.t) = Client.initialized client in + let* () = prep client in + let* () = + match settings with + | Some settings -> + Client.notification client (ChangeConfiguration { settings }) + | None -> Fiber.return () + in + Client.request client request + in + Fiber.fork_and_join_unit run_client (fun () -> + let* ret = run in + let* () = Fiber.Ivar.read diagnostics in + let+ () = Client.stop client in + ret) + +let openDocument ~client ~uri ~source = + let textDocument = + TextDocumentItem.create ~uri ~languageId:"ocaml" ~version:0 ~text:source + in + Client.notification + client + (TextDocumentDidOpen (DidOpenTextDocumentParams.create ~textDocument)) + +let offset_of_position src (pos : Position.t) = + let line_offset = + String.split_lines src |> List.take pos.line + |> List.fold_left ~init:0 ~f:(fun s l -> s + String.length l) + in + line_offset + pos.line (* account for line endings *) + pos.character + +let apply_edits src edits = + let edits = + List.sort edits ~compare:(fun (e : TextEdit.t) (e' : TextEdit.t) -> + Position.compare e.range.start e'.range.start) + in + + (* check that edits are non-overlapping *) + let rec overlaps : TextEdit.t list -> _ = function + | [] | [ _ ] -> false + | e :: e' :: es -> ( + match Position.compare e.range.end_ e'.range.start with + | Gt -> true + | Lt | Eq -> overlaps (e' :: es)) + in + if overlaps edits then failwith "overlapping edits"; + + let _, edits = + (* compute start and end character offsets for each edit *) + List.map edits ~f:(fun (e : TextEdit.t) -> + ( e.newText + , offset_of_position src e.range.start + , offset_of_position src e.range.end_ )) + (* update the offsets to account for preceding edits *) + |> List.fold_left_map ~init:0 ~f:(fun offset (new_text, start, end_) -> + if end_ < start then failwith "invalid edit: end before start"; + ( offset + (String.length new_text - (end_ - start)) + , (new_text, start + offset, end_ + offset) )) + in + (* apply edits *) + List.fold_left edits ~init:src ~f:(fun src (new_text, start, end_) -> + String.take src start ^ new_text ^ String.drop src end_)