Skip to content

Commit ea8b031

Browse files
awilliambauerawilliambauer
committed
improved document symbols
1 parent e485128 commit ea8b031

File tree

3 files changed

+345
-52
lines changed

3 files changed

+345
-52
lines changed

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

+311-48
Original file line numberDiff line numberDiff line change
@@ -1,65 +1,328 @@
11
open Import
22
open Fiber.O
33

4-
let outline_kind kind : SymbolKind.t =
5-
match kind with
6-
| `Value -> Function
7-
| `Constructor -> Constructor
8-
| `Label -> Property
9-
| `Module -> Module
10-
| `Modtype -> Module
11-
| `Type -> String
12-
| `Exn -> Constructor
13-
| `Class -> Class
14-
| `Method -> Method
4+
let core_type_to_string typ =
5+
ignore (Format.flush_str_formatter ());
6+
Pprintast.core_type Format.str_formatter typ;
7+
Format.flush_str_formatter ()
8+
|> String.map ~f:(function
9+
| '\n' -> ' '
10+
| c -> c)
11+
;;
1512

16-
let rec symbol (item : Query_protocol.item) =
17-
let children = List.map item.children ~f:symbol in
18-
let range = Range.of_loc item.location in
19-
let kind = outline_kind item.outline_kind in
13+
let pattern_to_string pat =
14+
ignore (Format.flush_str_formatter ());
15+
Pprintast.pattern Format.str_formatter pat;
16+
Format.flush_str_formatter ()
17+
;;
18+
19+
let type_document_symbol (decl : Parsetree.type_declaration) : DocumentSymbol.t =
20+
let kind : SymbolKind.t =
21+
match decl.ptype_kind with
22+
| Ptype_variant _ -> Enum
23+
| _ -> TypeParameter
24+
in
25+
let children =
26+
match decl.ptype_kind with
27+
| Ptype_variant decls ->
28+
List.map decls ~f:(fun (decl : Parsetree.constructor_declaration) ->
29+
DocumentSymbol.create
30+
~kind:EnumMember
31+
~name:decl.pcd_name.txt
32+
~range:(Range.of_loc decl.pcd_loc)
33+
~selectionRange:(Range.of_loc decl.pcd_name.loc)
34+
())
35+
| Ptype_record fields ->
36+
List.map fields ~f:(fun (field : Parsetree.label_declaration) ->
37+
DocumentSymbol.create
38+
~kind:Field
39+
~name:field.pld_name.txt
40+
~detail:(core_type_to_string field.pld_type)
41+
~range:(Range.of_loc field.pld_loc)
42+
~selectionRange:(Range.of_loc field.pld_name.loc)
43+
())
44+
| _ -> []
45+
in
2046
DocumentSymbol.create
21-
~name:item.outline_name
47+
~name:decl.ptype_name.txt
2248
~kind
23-
?detail:item.outline_type
24-
~deprecated:item.deprecated
49+
~range:(Range.of_loc decl.ptype_loc)
50+
~selectionRange:(Range.of_loc decl.ptype_loc)
51+
~children
52+
()
53+
;;
54+
55+
let longident_to_string lident = String.concat ~sep:"." (Longident.flatten lident)
56+
57+
let type_ext_document_symbol (ext : Parsetree.type_extension) : DocumentSymbol.t =
58+
let children =
59+
List.map ext.ptyext_constructors ~f:(fun (ext : Parsetree.extension_constructor) ->
60+
DocumentSymbol.create
61+
~name:ext.pext_name.txt
62+
~kind:EnumMember
63+
~range:(Range.of_loc ext.pext_loc)
64+
~selectionRange:(Range.of_loc ext.pext_loc)
65+
())
66+
in
67+
let range =
68+
List.fold_left
69+
children
70+
~init:(Range.of_loc ext.ptyext_path.loc)
71+
~f:(fun range child ->
72+
let start =
73+
match Position.compare range.start child.range.start with
74+
| Lt | Eq -> range.start
75+
| Gt -> child.range.start
76+
in
77+
let end_ =
78+
match Position.compare range.end_ child.range.end_ with
79+
| Lt | Eq -> child.range.end_
80+
| Gt -> range.end_
81+
in
82+
Range.create ~start ~end_)
83+
in
84+
DocumentSymbol.create
85+
~name:(longident_to_string ext.ptyext_path.txt)
86+
~kind:Enum
2587
~range
26-
~selectionRange:range
88+
~selectionRange:(Range.of_loc ext.ptyext_path.loc)
2789
~children
2890
()
91+
;;
2992

30-
let rec symbol_info ?containerName uri (item : Query_protocol.item) =
31-
let info =
32-
let kind = outline_kind item.outline_kind in
33-
let location = { Location.uri; range = Range.of_loc item.location } in
34-
SymbolInformation.create
35-
~name:item.outline_name
36-
~kind
37-
~deprecated:false
38-
~location
39-
?containerName
40-
()
93+
let value_document_symbol (value : Parsetree.value_description) =
94+
let kind : SymbolKind.t =
95+
match value.pval_type.ptyp_desc with
96+
| Ptyp_arrow _ -> Function
97+
| _ -> Variable
4198
in
42-
let children =
43-
List.concat_map item.children ~f:(symbol_info uri ~containerName:info.name)
99+
DocumentSymbol.create
100+
~kind
101+
~name:value.pval_name.txt
102+
~detail:(core_type_to_string value.pval_type)
103+
~range:(Range.of_loc value.pval_loc)
104+
~selectionRange:(Range.of_loc value.pval_name.loc)
105+
()
106+
;;
107+
108+
let module_decl_document_symbol (pmod : Parsetree.module_declaration) ~children =
109+
DocumentSymbol.create
110+
~name:(Option.value pmod.pmd_name.txt ~default:"_")
111+
~kind:Module
112+
~range:(Range.of_loc pmod.pmd_loc)
113+
~selectionRange:(Range.of_loc pmod.pmd_name.loc)
114+
~children
115+
()
116+
;;
117+
118+
let module_type_decl_symbol (decl : Parsetree.module_type_declaration) ~children =
119+
DocumentSymbol.create
120+
~name:decl.pmtd_name.txt
121+
~kind:Interface
122+
~range:(Range.of_loc decl.pmtd_loc)
123+
~selectionRange:(Range.of_loc decl.pmtd_name.loc)
124+
~children
125+
()
126+
;;
127+
128+
let module_binding_document_symbol (pmod : Parsetree.module_binding) ~children =
129+
DocumentSymbol.create
130+
~name:(Option.value pmod.pmb_name.txt ~default:"_")
131+
~kind:Module
132+
~range:(Range.of_loc pmod.pmb_loc)
133+
~selectionRange:(Range.of_loc pmod.pmb_name.loc)
134+
~children
135+
()
136+
;;
137+
138+
let binding_document_symbol
139+
(binding : Parsetree.value_binding)
140+
~ppx
141+
~is_top_level
142+
~children
143+
=
144+
let variables_in_pattern (pattern : Parsetree.pattern) =
145+
let symbols = ref [] in
146+
let pat (iterator : Ast_iterator.iterator) (pattern : Parsetree.pattern) =
147+
match pattern.ppat_desc with
148+
| Ppat_var name ->
149+
let symbol =
150+
DocumentSymbol.create
151+
~kind:Variable
152+
~name:name.txt
153+
~range:(Range.of_loc name.loc)
154+
~selectionRange:(Range.of_loc name.loc)
155+
()
156+
in
157+
symbols := symbol :: !symbols
158+
| _ -> Ast_iterator.default_iterator.pat iterator pattern
159+
in
160+
let iterator = { Ast_iterator.default_iterator with pat } in
161+
iterator.pat iterator pattern;
162+
List.rev !symbols
163+
in
164+
let name =
165+
match binding.pvb_pat.ppat_desc with
166+
| Ppat_var name | Ppat_extension (_, PPat ({ ppat_desc = Ppat_var name; _ }, _)) ->
167+
`Parent name.txt
168+
| _ ->
169+
(match is_top_level, children with
170+
| true, [] | false, _ -> `Variables (variables_in_pattern binding.pvb_pat)
171+
| true, _ :: _ ->
172+
(match ppx with
173+
| Some ppx -> `Parent (ppx ^ ": " ^ pattern_to_string binding.pvb_pat)
174+
| None -> `Parent (pattern_to_string binding.pvb_pat)))
175+
in
176+
match name with
177+
| `Parent name ->
178+
let kind : SymbolKind.t =
179+
match ppx, binding.pvb_expr.pexp_desc with
180+
| None, (Pexp_function _ | Pexp_fun _ | Pexp_newtype _) -> Function
181+
| Some _, _ -> Property
182+
| _ -> Variable
183+
in
184+
let detail =
185+
Option.map binding.pvb_constraint ~f:(function
186+
| Pvc_constraint { typ; _ } -> core_type_to_string typ
187+
| Pvc_coercion { coercion; _ } -> core_type_to_string coercion)
188+
in
189+
[ DocumentSymbol.create
190+
~name
191+
~kind
192+
?detail
193+
~range:(Range.of_loc binding.pvb_loc)
194+
~selectionRange:(Range.of_loc binding.pvb_pat.ppat_loc)
195+
~children
196+
()
197+
]
198+
| `Variables symbols -> symbols @ children
199+
;;
200+
201+
let symbols_from_parsetree parsetree =
202+
let current = ref [] in
203+
let descend
204+
(iter : unit -> unit)
205+
(get_current_symbol : children:DocumentSymbol.t list -> DocumentSymbol.t)
206+
=
207+
let outer = !current in
208+
current := [];
209+
iter ();
210+
current := outer @ [ get_current_symbol ~children:!current ]
211+
in
212+
let signature_item (iterator : Ast_iterator.iterator) (item : Parsetree.signature_item) =
213+
match item.psig_desc with
214+
| Psig_type (_, decls) -> current := !current @ List.map decls ~f:type_document_symbol
215+
| Psig_typext ext -> current := !current @ [ type_ext_document_symbol ext ]
216+
| Psig_value value -> current := !current @ [ value_document_symbol value ]
217+
| Psig_module pmd ->
218+
descend
219+
(fun () -> Ast_iterator.default_iterator.signature_item iterator item)
220+
(module_decl_document_symbol pmd)
221+
| Psig_recmodule modules ->
222+
List.iter modules ~f:(iterator.module_declaration iterator)
223+
| Psig_modtype decl ->
224+
descend
225+
(fun () -> Ast_iterator.default_iterator.module_type_declaration iterator decl)
226+
(module_type_decl_symbol decl)
227+
| _ -> Ast_iterator.default_iterator.signature_item iterator item
228+
in
229+
let rec structure_item
230+
~ppx
231+
(iterator : Ast_iterator.iterator)
232+
(item : Parsetree.structure_item)
233+
=
234+
match item.pstr_desc with
235+
| Pstr_type (_, decls) -> current := !current @ List.map decls ~f:type_document_symbol
236+
| Pstr_typext ext -> current := !current @ [ type_ext_document_symbol ext ]
237+
| Pstr_module pmod ->
238+
descend
239+
(fun () -> iterator.module_expr iterator pmod.pmb_expr)
240+
(module_binding_document_symbol pmod)
241+
| Pstr_recmodule modules -> List.iter modules ~f:(iterator.module_binding iterator)
242+
| Pstr_modtype decl ->
243+
descend
244+
(fun () -> Ast_iterator.default_iterator.module_type_declaration iterator decl)
245+
(module_type_decl_symbol decl)
246+
| Pstr_value (_, bindings) ->
247+
let outer = !current in
248+
current
249+
:= outer
250+
@ List.concat_map bindings ~f:(fun (binding : Parsetree.value_binding) ->
251+
current := [];
252+
iterator.expr iterator binding.pvb_expr;
253+
binding_document_symbol binding ~ppx ~is_top_level:true ~children:!current)
254+
| Pstr_extension ((name, PStr items), _) ->
255+
List.iter items ~f:(fun item -> structure_item ~ppx:(Some name.txt) iterator item)
256+
| _ -> Ast_iterator.default_iterator.structure_item iterator item
257+
in
258+
let expr (iterator : Ast_iterator.iterator) (item : Parsetree.expression) =
259+
match item.pexp_desc with
260+
| Pexp_let (_, bindings, inner) ->
261+
let outer = !current in
262+
let bindings =
263+
List.concat_map bindings ~f:(fun (binding : Parsetree.value_binding) ->
264+
current := [];
265+
iterator.expr iterator binding.pvb_expr;
266+
binding_document_symbol binding ~ppx:None ~is_top_level:false ~children:!current)
267+
in
268+
current := outer @ bindings;
269+
iterator.expr iterator inner
270+
| _ -> Ast_iterator.default_iterator.expr iterator item
271+
in
272+
let iterator =
273+
{ Ast_iterator.default_iterator with
274+
signature_item
275+
; structure_item = structure_item ~ppx:None
276+
; expr
277+
}
278+
in
279+
let () =
280+
match parsetree with
281+
| `Interface signature -> iterator.signature iterator signature
282+
| `Implementation structure -> iterator.structure iterator structure
44283
in
45-
info :: children
284+
!current
285+
;;
46286

47-
let symbols_of_outline uri outline =
48-
List.concat_map ~f:(symbol_info uri) outline
287+
let rec flatten_document_symbols ~uri ~container_name (symbols : DocumentSymbol.t list) =
288+
List.concat_map symbols ~f:(fun symbol ->
289+
let symbol_information =
290+
SymbolInformation.create
291+
?containerName:container_name
292+
~kind:symbol.kind
293+
~location:{ range = symbol.range; uri }
294+
~name:symbol.name
295+
()
296+
in
297+
let children =
298+
flatten_document_symbols
299+
~uri
300+
~container_name:(Some symbol.name)
301+
(Option.value symbol.children ~default:[])
302+
in
303+
symbol_information :: children)
304+
;;
49305

50306
let run (client_capabilities : ClientCapabilities.t) doc uri =
51307
match Document.kind doc with
52308
| `Other -> Fiber.return None
53-
| `Merlin doc ->
54-
let+ outline = Document.Merlin.dispatch_exn doc Outline in
55-
Some
56-
(match
57-
Option.value
58-
~default:false
59-
(let open Option.O in
60-
let* textDocument = client_capabilities.textDocument in
61-
let* ds = textDocument.documentSymbol in
62-
ds.hierarchicalDocumentSymbolSupport)
63-
with
64-
| true -> `DocumentSymbol (List.map outline ~f:symbol)
65-
| false -> `SymbolInformation (symbols_of_outline uri outline))
309+
| `Merlin _ ->
310+
let+ symbols =
311+
Document.Merlin.with_pipeline_exn
312+
~name:"document-symbols"
313+
(Document.merlin_exn doc)
314+
(fun pipeline -> Mpipeline.reader_parsetree pipeline |> symbols_from_parsetree)
315+
in
316+
(match
317+
Option.value
318+
~default:false
319+
(let open Option.O in
320+
let* textDocument = client_capabilities.textDocument in
321+
let* ds = textDocument.documentSymbol in
322+
ds.hierarchicalDocumentSymbolSupport)
323+
with
324+
| true -> Some (`DocumentSymbol symbols)
325+
| false ->
326+
let flattened = flatten_document_symbols ~uri ~container_name:None symbols in
327+
Some (`SymbolInformation flattened))
328+
;;

‎ocaml-lsp-server/src/document_symbol.mli

-3
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,5 @@
11
open Import
22

3-
val symbols_of_outline :
4-
Uri.t -> Query_protocol.item list -> SymbolInformation.t list
5-
63
val run :
74
ClientCapabilities.t
85
-> Document.t

0 commit comments

Comments
 (0)