Skip to content

Commit

Permalink
Relay on Query_commands for Type enclosing query
Browse files Browse the repository at this point in the history
  • Loading branch information
@xvw
xvw committed Jun 20, 2024
1 parent b35f219 commit 685e5d4
Show file tree
Hide file tree
Showing 2 changed files with 85 additions and 149 deletions.
150 changes: 44 additions & 106 deletions ocaml-lsp-server/src/custom_requests/req_type_enclosing.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -75,41 +75,6 @@ let of_yojson_exn = function
in
raise_invalid_params ~data ~message:"Unexpected params format" ())

let get_position pipeline text_document_position =
let pos =
text_document_position.Lsp.Types.TextDocumentPositionParams.position
in
let pos = Position.logical pos in
Mpipeline.get_lexing_pos pipeline pos

let parse_identifier (config, source) pos =
(* FIXME: in latest Merlin version the function is located in
Merlin_analysis. *)
let path = Mreader.reconstruct_identifier config source pos in
Merlin_kernel.Mreader_lexer.identifier_suffix path

let reconstruct_identifier pipeline pos =
let config = Mpipeline.input_config pipeline in
let source = Mpipeline.raw_source pipeline in
let path = parse_identifier (config, source) pos in
let reify dot =
if
String.equal "" dot
|| (dot.[0] >= 'a' && dot.[0] <= 'z')
|| (dot.[0] >= 'A' && dot.[0] <= 'Z')
then dot
else "( " ^ dot ^ ")"
in
match path with
| [] -> []
| base :: tail ->
let f { Loc.txt = base; loc = bl } { Loc.txt = dot; loc = dl } =
let loc = Merlin_parsing.Location_aux.union bl dl in
let txt = base ^ "." ^ reify dot in
Merlin_parsing.Location.mkloc txt loc
in
[ List.fold_left tail ~init:base ~f ]

let overlap_with_range_end range = function
| None -> true
| Some position ->
Expand All @@ -118,84 +83,57 @@ let overlap_with_range_end range = function
lend.character > position.character
else lend.line > position.line

let collect_all_results verbosity small_enclosing range_end result =
let ppf = Format.str_formatter in
List.filter_map
~f:(fun (loc, text, _tail) ->
let range = Range.of_loc loc in
let ret x = Some (range, x) in
let open Merlin_analysis in
match text with
| _ when not (overlap_with_range_end range range_end) -> None
| Type_enclosing.String str -> ret str
| Type_enclosing.Type (env, t) ->
Type_utils.Printtyp.wrap_printing_env env ~verbosity (fun () ->
Type_utils.print_type_with_decl ~verbosity env ppf t);
ret (Format.flush_str_formatter ())
| Type_enclosing.Type_decl (env, id, t) ->
Type_utils.Printtyp.wrap_printing_env env ~verbosity (fun () ->
Type_utils.Printtyp.type_declaration env id ppf t);
ret (Format.flush_str_formatter ())
| Type_enclosing.Modtype (env, m) ->
Type_utils.Printtyp.wrap_printing_env env ~verbosity (fun () ->
Type_utils.Printtyp.modtype env ppf m);
ret (Format.flush_str_formatter ()))
(small_enclosing @ result)
|> Merlin_utils.Std.List.merge_cons
~f:(fun (a_range, a_typ) (b_range, b_typ) ->
if Range.compare a_range b_range = Eq && String.equal a_typ b_typ then
Some (b_range, b_typ)
else None)

let type_enclosing text_document_position verbosity range_end pipeline =
let typer = Mpipeline.typer_result pipeline in
let pos = get_position pipeline text_document_position in
let structures =
Mbrowse.(enclosing pos [ of_typedtree @@ Mtyper.get_typedtree typer ])
in
let path =
match structures with
| [] -> []
| browse -> Merlin_analysis.Browse_misc.annotate_tail_calls browse
in
let result = Merlin_analysis.Type_enclosing.from_nodes ~path in
let expression = reconstruct_identifier pipeline pos in
let small_enclosing =
Merlin_analysis.Type_enclosing.from_reconstructed
~nodes:structures
~cursor:pos
~verbosity
expression
in
collect_all_results verbosity small_enclosing range_end result

let render_result index result =
let current_typ =
match index |> List.nth result with
| None -> "<no information>"
| Some (_, typ) -> typ
in
let enclosings =
List.map
~f:(fun (loc, typ) ->
`Assoc
[ ("start", Position.yojson_of_t loc.Range.start)
; ("end_", Position.yojson_of_t loc.Range.end_)
; ("type", `String typ)
])
result
let typ, enclosings =
match result with
| None -> ("<no information>", [])
| Some (typ, enclosings) ->
(typ, List.map ~f:Lsp.Types.Range.yojson_of_t enclosings)
in
`Assoc
[ ("index", `Int index)
; ("enclosings", `List enclosings)
; ("type", `String current_typ)
; ("type", `String typ)
]

let with_pipeline state uri f =
let config_with_given_verbosity config verbosity =
let open Mconfig in
{ config with query = { config.query with verbosity } }

let with_pipeline state uri verbosity with_pipeline =
let doc = Document_store.get state.State.store uri in
match Document.kind doc with
| `Other -> Fiber.return []
| `Merlin merlin -> Document.Merlin.with_pipeline_exn merlin f
| `Other -> Fiber.return None
| `Merlin merlin ->
let open Fiber.O in
let* config = Document.Merlin.mconfig merlin in
Document.Merlin.with_configurable_pipeline_exn
~config:(config_with_given_verbosity config verbosity)
merlin
with_pipeline

let make_enclosing_command position index =
Query_protocol.Type_enclosing (None, position, Some index)

let get_logical_position tdp =
let p = tdp.Lsp.Types.TextDocumentPositionParams.position in
Position.logical p

let dispatch_type_enclosing text_document_position index range_end pipeline =
let position = get_logical_position text_document_position in
let dummy_command = make_enclosing_command position (-1) in
let command = make_enclosing_command position index in
let enclosings = Query_commands.dispatch pipeline dummy_command in
match Query_commands.dispatch pipeline command with
| (_, `String typ, _) :: _ ->
Some
( typ
, List.filter_map
~f:(fun (loc, _, _) ->
let range = Range.of_loc loc in
if overlap_with_range_end range range_end then Some range else None)
enclosings )
| _ -> None

let on_request ~params state =
Fiber.of_thunk (fun () ->
Expand All @@ -206,7 +144,7 @@ let on_request ~params state =
let uri = text_document_position.textDocument.uri in
let verbosity = Mconfig.Verbosity.Lvl verbosity in
let+ result =
with_pipeline state uri
@@ type_enclosing text_document_position verbosity range_end
with_pipeline state uri verbosity
@@ dispatch_type_enclosing text_document_position index range_end
in
render_result index result)
84 changes: 41 additions & 43 deletions ocaml-lsp-server/test/e2e-new/type_enclosing.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,14 +41,12 @@ let%expect_test "type enclosing on simple example" =
"index": 0,
"enclosings": [
{
"start": { "character": 22, "line": 0 },
"end_": { "character": 26, "line": 0 },
"type": "int"
"end": { "character": 26, "line": 0 },
"start": { "character": 22, "line": 0 }
},
{
"start": { "character": 8, "line": 0 },
"end_": { "character": 26, "line": 0 },
"type": "string"
"end": { "character": 26, "line": 0 },
"start": { "character": 8, "line": 0 }
}
],
"type": "int"
Expand Down Expand Up @@ -76,14 +74,12 @@ let a = Foo 3|}
"index": 0,
"enclosings": [
{
"start": { "character": 8, "line": 4 },
"end_": { "character": 11, "line": 4 },
"type": "int -> t"
"end": { "character": 11, "line": 4 },
"start": { "character": 8, "line": 4 }
},
{
"start": { "character": 8, "line": 4 },
"end_": { "character": 13, "line": 4 },
"type": "t"
"end": { "character": 13, "line": 4 },
"start": { "character": 8, "line": 4 }
}
],
"type": "int -> t"
Expand Down Expand Up @@ -112,12 +108,11 @@ let a = Foo 3|}
"index": 0,
"enclosings": [
{
"start": { "character": 8, "line": 4 },
"end_": { "character": 13, "line": 4 },
"type": "t"
"end": { "character": 13, "line": 4 },
"start": { "character": 8, "line": 4 }
}
],
"type": "t"
"type": "int -> t"
} |}]

let cons_ml =
Expand Down Expand Up @@ -165,9 +160,12 @@ let%expect_test "type enclosing constructors_and_path - 1" =
"index": 0,
"enclosings": [
{
"start": { "character": 13, "line": 3 },
"end_": { "character": 14, "line": 3 },
"type": "t"
"end": { "character": 14, "line": 3 },
"start": { "character": 13, "line": 3 }
},
{
"end": { "character": 14, "line": 3 },
"start": { "character": 13, "line": 3 }
}
],
"type": "t"
Expand All @@ -189,19 +187,24 @@ let%expect_test "type enclosing constructors_and_path - 2" =
"index": 0,
"enclosings": [
{
"start": { "character": 4, "line": 7 },
"end_": { "character": 5, "line": 7 },
"type": "t"
"end": { "character": 5, "line": 7 },
"start": { "character": 4, "line": 7 }
},
{
"end": { "character": 5, "line": 7 },
"start": { "character": 4, "line": 7 }
},
{
"end": { "character": 5, "line": 7 },
"start": { "character": 4, "line": 7 }
},
{
"start": { "character": 2, "line": 6 },
"end_": { "character": 11, "line": 7 },
"type": "unit"
"end": { "character": 11, "line": 7 },
"start": { "character": 2, "line": 6 }
},
{
"start": { "character": 6, "line": 5 },
"end_": { "character": 11, "line": 7 },
"type": "t -> unit"
"end": { "character": 11, "line": 7 },
"start": { "character": 6, "line": 5 }
}
],
"type": "t"
Expand All @@ -223,14 +226,12 @@ let%expect_test "type enclosing constructors_and_path - 3" =
"index": 0,
"enclosings": [
{
"start": { "character": 8, "line": 16 },
"end_": { "character": 9, "line": 16 },
"type": "sig type t = A type u = A | B end"
"end": { "character": 9, "line": 16 },
"start": { "character": 8, "line": 16 }
},
{
"start": { "character": 8, "line": 16 },
"end_": { "character": 11, "line": 16 },
"type": "M.u"
"end": { "character": 11, "line": 16 },
"start": { "character": 8, "line": 16 }
}
],
"type": "sig type t = A type u = A | B end"
Expand All @@ -252,19 +253,16 @@ let%expect_test "type enclosing constructors_and_path with reconstruction - 4" =
"index": 0,
"enclosings": [
{
"start": { "character": 14, "line": 23 },
"end_": { "character": 15, "line": 23 },
"type": "sig type t = A of int val x : int end"
"end": { "character": 15, "line": 23 },
"start": { "character": 14, "line": 23 }
},
{
"start": { "character": 13, "line": 23 },
"end_": { "character": 20, "line": 23 },
"type": "N.t"
"end": { "character": 20, "line": 23 },
"start": { "character": 13, "line": 23 }
},
{
"start": { "character": 8, "line": 23 },
"end_": { "character": 20, "line": 23 },
"type": "N.t option"
"end": { "character": 20, "line": 23 },
"start": { "character": 8, "line": 23 }
}
],
"type": "sig type t = A of int val x : int end"
Expand Down

0 comments on commit 685e5d4

Please sign in to comment.