Skip to content

Commit 019f835

Browse files
jfeserjfeser
authored
Batch merlin work in code actions (#1156)
* try batching merlin work * add comments
1 parent ca325e7 commit 019f835

13 files changed

+305
-300
lines changed

‎ocaml-lsp-server/src/code_actions.ml

Lines changed: 68 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,72 @@ module Code_action_error_monoid = struct
2424
include Stdune.Monoid.Make (Code_action_error)
2525
end
2626

27+
let compute_ocaml_code_actions (params : CodeActionParams.t) state doc =
28+
let action_is_enabled =
29+
match params.context.only with
30+
| None -> fun _ -> true
31+
| Some set ->
32+
fun (action : Code_action.t) -> List.mem set action.kind ~equal:Poly.equal
33+
in
34+
let enabled_actions =
35+
List.filter
36+
~f:action_is_enabled
37+
[ Action_destruct.t state
38+
; Action_inferred_intf.t state
39+
; Action_type_annotate.t
40+
; Action_remove_type_annotation.t
41+
; Action_construct.t
42+
; Action_refactor_open.unqualify
43+
; Action_refactor_open.qualify
44+
; Action_add_rec.t
45+
; Action_mark_remove_unused.mark
46+
; Action_mark_remove_unused.remove
47+
; Action_inline.t
48+
; Action_extract.local
49+
; Action_extract.function_
50+
]
51+
in
52+
let batchable, non_batchable =
53+
List.partition_map
54+
~f:(fun ca ->
55+
match ca.run with
56+
| `Batchable f -> Left f
57+
| `Non_batchable f -> Right f)
58+
enabled_actions
59+
in
60+
let* batch_results =
61+
if List.is_empty batchable then Fiber.return []
62+
else
63+
Document.Merlin.with_pipeline_exn
64+
(Document.merlin_exn doc)
65+
(fun pipeline ->
66+
List.filter_map batchable ~f:(fun ca ->
67+
try ca pipeline doc params
68+
with Merlin_extend.Extend_main.Handshake.Error _ -> None))
69+
in
70+
let code_action ca =
71+
let+ res =
72+
Fiber.map_reduce_errors
73+
~on_error:(fun (exn : Exn_with_backtrace.t) ->
74+
match exn.exn with
75+
| Merlin_extend.Extend_main.Handshake.Error error ->
76+
Fiber.return (Code_action_error.Need_merlin_extend error)
77+
| _ -> Fiber.return (Code_action_error.Exn exn))
78+
(module Code_action_error_monoid)
79+
(fun () -> ca doc params)
80+
in
81+
match res with
82+
| Ok res -> res
83+
| Error Initial -> assert false
84+
| Error (Need_merlin_extend _) -> None
85+
| Error (Exn exn) -> Exn_with_backtrace.reraise exn
86+
in
87+
let+ non_batch_results =
88+
Fiber.parallel_map non_batchable ~f:code_action
89+
|> Fiber.map ~f:List.filter_opt
90+
in
91+
batch_results @ non_batch_results
92+
2793
let compute server (params : CodeActionParams.t) =
2894
let state : State.t = Server.state server in
2995
let uri = params.textDocument.uri in
@@ -51,53 +117,13 @@ let compute server (params : CodeActionParams.t) =
51117
in
52118
match Document.syntax doc with
53119
| Ocamllex | Menhir | Cram | Dune ->
54-
let state : State.t = Server.state server in
55120
Fiber.return (Reply.now (actions (dune_actions @ open_related)), state)
56121
| Ocaml | Reason ->
57122
let reply () =
58-
let code_action (ca : Code_action.t) =
59-
match params.context.only with
60-
| Some set when not (List.mem set ca.kind ~equal:Poly.equal) ->
61-
Fiber.return None
62-
| Some _ | None -> (
63-
let+ res =
64-
Fiber.map_reduce_errors
65-
~on_error:(fun (exn : Exn_with_backtrace.t) ->
66-
match exn.exn with
67-
| Merlin_extend.Extend_main.Handshake.Error error ->
68-
Fiber.return (Code_action_error.Need_merlin_extend error)
69-
| _ -> Fiber.return (Code_action_error.Exn exn))
70-
(module Code_action_error_monoid)
71-
(fun () -> ca.run doc params)
72-
in
73-
match res with
74-
| Ok res -> res
75-
| Error Initial -> assert false
76-
| Error (Need_merlin_extend _) -> None
77-
| Error (Exn exn) -> Exn_with_backtrace.reraise exn)
78-
in
79123
let+ code_action_results =
80-
(* XXX this is a really bad use of resources. we should be batching
81-
all the merlin related work *)
82-
Fiber.parallel_map
83-
~f:code_action
84-
[ Action_destruct.t state
85-
; Action_inferred_intf.t state
86-
; Action_type_annotate.t
87-
; Action_remove_type_annotation.t
88-
; Action_construct.t
89-
; Action_refactor_open.unqualify
90-
; Action_refactor_open.qualify
91-
; Action_add_rec.t
92-
; Action_mark_remove_unused.mark
93-
; Action_mark_remove_unused.remove
94-
; Action_inline.t
95-
; Action_extract.local
96-
; Action_extract.function_
97-
]
124+
compute_ocaml_code_actions params state doc
98125
in
99-
List.concat
100-
[ List.filter_opt code_action_results; dune_actions; open_related ]
126+
List.concat [ code_action_results; dune_actions; open_related ]
101127
|> actions
102128
in
103129
let later f =

‎ocaml-lsp-server/src/code_actions/action_add_rec.ml

Lines changed: 18 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
open Import
2-
open Fiber.O
2+
open Option.O
33

44
let action_title = "Add missing `rec` keyword"
55

@@ -64,29 +64,21 @@ let code_action_add_rec uri diagnostics doc loc =
6464
~isPreferred:false
6565
()
6666

67-
let code_action doc (params : CodeActionParams.t) =
68-
match Document.kind doc with
69-
| `Other -> Fiber.return None
70-
| `Merlin merlin -> (
71-
let pos_start = Position.logical params.range.start in
72-
let m_diagnostic =
73-
List.find params.context.diagnostics ~f:(fun d ->
74-
let is_unbound () =
75-
String.is_prefix d.Diagnostic.message ~prefix:"Unbound value"
76-
and in_range () =
77-
match Position.compare_inclusion params.range.start d.range with
78-
| `Outside _ -> false
79-
| `Inside -> true
80-
in
81-
in_range () && is_unbound ())
82-
in
83-
match m_diagnostic with
84-
| None -> Fiber.return None
85-
| Some d ->
86-
let+ loc =
87-
Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
88-
has_missing_rec pipeline pos_start)
89-
in
90-
Option.map loc ~f:(code_action_add_rec params.textDocument.uri [ d ] doc))
67+
let code_action pipeline doc (params : CodeActionParams.t) =
68+
let pos_start = Position.logical params.range.start in
69+
let* diagnostic =
70+
List.find params.context.diagnostics ~f:(fun d ->
71+
let is_unbound () =
72+
String.is_prefix d.Diagnostic.message ~prefix:"Unbound value"
73+
and in_range () =
74+
match Position.compare_inclusion params.range.start d.range with
75+
| `Outside _ -> false
76+
| `Inside -> true
77+
in
78+
in_range () && is_unbound ())
79+
in
80+
has_missing_rec pipeline pos_start
81+
|> Option.map
82+
~f:(code_action_add_rec params.textDocument.uri [ diagnostic ] doc)
9183

92-
let t = { Code_action.kind = QuickFix; run = code_action }
84+
let t = Code_action.batchable QuickFix code_action

‎ocaml-lsp-server/src/code_actions/action_construct.ml

Lines changed: 13 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -1,30 +1,28 @@
11
open Import
2-
open Fiber.O
32

43
let action_kind = "construct"
54

6-
let code_action doc (params : CodeActionParams.t) =
5+
let code_action pipeline doc (params : CodeActionParams.t) =
76
match Document.kind doc with
8-
| `Other -> Fiber.return None
9-
| `Merlin m when Document.Merlin.kind m = Intf -> Fiber.return None
10-
| `Merlin merlin ->
7+
| `Other -> None
8+
| `Merlin m when Document.Merlin.kind m = Intf -> None
9+
| `Merlin _ ->
1110
let pos = Position.logical params.range.Range.end_ in
1211
(* we want this predicate to quickly eliminate prefixes that don't fit to be
1312
a hole *)
1413
let prefix =
1514
let src = Document.source doc in
1615
Compl.prefix_of_position ~short_path:false src pos
1716
in
18-
if not (Typed_hole.can_be_hole prefix) then Fiber.return None
17+
if not (Typed_hole.can_be_hole prefix) then None
1918
else
20-
let+ structures =
21-
Document.Merlin.with_pipeline_exn merlin (fun pipeline ->
22-
let typedtree =
23-
let typer = Mpipeline.typer_result pipeline in
24-
Mtyper.get_typedtree typer
25-
in
26-
let pos = Mpipeline.get_lexing_pos pipeline pos in
27-
Mbrowse.enclosing pos [ Mbrowse.of_typedtree typedtree ])
19+
let structures =
20+
let typedtree =
21+
let typer = Mpipeline.typer_result pipeline in
22+
Mtyper.get_typedtree typer
23+
in
24+
let pos = Mpipeline.get_lexing_pos pipeline pos in
25+
Mbrowse.enclosing pos [ Mbrowse.of_typedtree typedtree ]
2826
in
2927
if not (Typed_hole.is_a_hole structures) then None
3028
else
@@ -52,4 +50,4 @@ let code_action doc (params : CodeActionParams.t) =
5250
in
5351
Some code_action
5452

55-
let t = { Code_action.kind = Other action_kind; run = code_action }
53+
let t = Code_action.batchable (Other action_kind) code_action

‎ocaml-lsp-server/src/code_actions/action_destruct.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -81,4 +81,4 @@ let code_action (state : State.t) doc (params : CodeActionParams.t) =
8181
} -> Fiber.return None
8282
| Error exn -> Exn_with_backtrace.reraise exn)
8383

84-
let t state = { Code_action.kind; run = code_action state }
84+
let t state = { Code_action.kind; run = `Non_batchable (code_action state) }

‎ocaml-lsp-server/src/code_actions/action_extract.ml

Lines changed: 34 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,5 @@
11
open Import
2+
open Option.O
23
module H = Ocaml_parsing.Ast_helper
34

45
let range_contains_loc range loc =
@@ -133,7 +134,6 @@ let must_pass expr env =
133134
|> List.map ~f:fst
134135

135136
let extract_local doc typedtree range =
136-
let open Option.O in
137137
let* to_extract = largest_enclosed_expression typedtree range in
138138
let* extract_range = Range.of_loc_opt to_extract.exp_loc in
139139
let* edit_pos = tightest_enclosing_binder_position typedtree range in
@@ -147,7 +147,6 @@ let extract_local doc typedtree range =
147147
]
148148

149149
let extract_function doc typedtree range =
150-
let open Option.O in
151150
let* to_extract = largest_enclosed_expression typedtree range in
152151
let* extract_range = Range.of_loc_opt to_extract.exp_loc in
153152
let* parent_item = enclosing_structure_item typedtree range in
@@ -173,45 +172,36 @@ let extract_function doc typedtree range =
173172
; TextEdit.create ~newText:new_call ~range:extract_range
174173
]
175174

176-
let run_extract_local doc (params : CodeActionParams.t) =
177-
let open Option.O in
178-
Document.Merlin.with_pipeline_exn
179-
(Document.merlin_exn doc)
180-
Mpipeline.typer_result
181-
|> Fiber.map ~f:(fun typer ->
182-
let* typedtree =
183-
match Mtyper.get_typedtree typer with
184-
| `Interface _ -> None
185-
| `Implementation x -> Some x
186-
in
187-
let+ edits = extract_local doc typedtree params.range in
188-
CodeAction.create
189-
~title:"Extract local"
190-
~kind:CodeActionKind.RefactorExtract
191-
~edit:(Document.edit doc edits)
192-
~isPreferred:false
193-
())
194-
195-
let run_extract_function doc (params : CodeActionParams.t) =
196-
let open Option.O in
197-
Document.Merlin.with_pipeline_exn
198-
(Document.merlin_exn doc)
199-
Mpipeline.typer_result
200-
|> Fiber.map ~f:(fun typer ->
201-
let* typedtree =
202-
match Mtyper.get_typedtree typer with
203-
| `Interface _ -> None
204-
| `Implementation x -> Some x
205-
in
206-
let+ edits = extract_function doc typedtree params.range in
207-
CodeAction.create
208-
~title:"Extract function"
209-
~kind:CodeActionKind.RefactorExtract
210-
~edit:(Document.edit doc edits)
211-
~isPreferred:false
212-
())
213-
214-
let local = { Code_action.kind = RefactorExtract; run = run_extract_local }
215-
216-
let function_ =
217-
{ Code_action.kind = RefactorExtract; run = run_extract_function }
175+
let run_extract_local pipeline doc (params : CodeActionParams.t) =
176+
let typer = Mpipeline.typer_result pipeline in
177+
let* typedtree =
178+
match Mtyper.get_typedtree typer with
179+
| `Interface _ -> None
180+
| `Implementation x -> Some x
181+
in
182+
let+ edits = extract_local doc typedtree params.range in
183+
CodeAction.create
184+
~title:"Extract local"
185+
~kind:CodeActionKind.RefactorExtract
186+
~edit:(Document.edit doc edits)
187+
~isPreferred:false
188+
()
189+
190+
let run_extract_function pipeline doc (params : CodeActionParams.t) =
191+
let typer = Mpipeline.typer_result pipeline in
192+
let* typedtree =
193+
match Mtyper.get_typedtree typer with
194+
| `Interface _ -> None
195+
| `Implementation x -> Some x
196+
in
197+
let+ edits = extract_function doc typedtree params.range in
198+
CodeAction.create
199+
~title:"Extract function"
200+
~kind:CodeActionKind.RefactorExtract
201+
~edit:(Document.edit doc edits)
202+
~isPreferred:false
203+
()
204+
205+
let local = Code_action.batchable RefactorExtract run_extract_local
206+
207+
let function_ = Code_action.batchable RefactorExtract run_extract_function

‎ocaml-lsp-server/src/code_actions/action_inferred_intf.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -45,4 +45,4 @@ let code_action (state : State.t) doc (params : CodeActionParams.t) =
4545

4646
let kind = CodeActionKind.Other action_kind
4747

48-
let t state = { Code_action.kind; run = code_action state }
48+
let t state = { Code_action.kind; run = `Non_batchable (code_action state) }

0 commit comments

Comments
 (0)