@@ -26,6 +26,13 @@ let kindNumber = function
26
26
27
27
let command ~path =
28
28
let symbols = ref [] in
29
+ let addSymbol name loc kind =
30
+ let range = Utils. cmtLocToRange loc in
31
+ let symbol : Protocol.documentSymbolItem =
32
+ {name; range; kind = kindNumber kind; children = [] }
33
+ in
34
+ symbols := symbol :: ! symbols
35
+ in
29
36
let rec exprKind (exp : Parsetree.expression ) =
30
37
match exp.pexp_desc with
31
38
| Pexp_fun _ -> Function
@@ -41,43 +48,41 @@ let command ~path =
41
48
| Ptype_variant constrDecls ->
42
49
constrDecls
43
50
|> List. iter (fun (cd : Parsetree.constructor_declaration ) ->
44
- symbols := ( cd.pcd_name.txt, cd.pcd_loc, EnumMember ) :: ! symbols )
51
+ addSymbol cd.pcd_name.txt cd.pcd_loc EnumMember )
45
52
| Ptype_record labelDecls ->
46
53
labelDecls
47
54
|> List. iter (fun (ld : Parsetree.label_declaration ) ->
48
- symbols := ( ld.pld_name.txt, ld.pld_loc, Property ) :: ! symbols )
55
+ addSymbol ld.pld_name.txt ld.pld_loc Property )
49
56
| _ -> ()
50
57
in
51
58
let processTypeDeclaration (td : Parsetree.type_declaration ) =
52
- symbols := ( td.ptype_name.txt, td.ptype_loc, TypeParameter ) :: ! symbols ;
59
+ addSymbol td.ptype_name.txt td.ptype_loc TypeParameter ;
53
60
processTypeKind td.ptype_kind
54
61
in
55
62
let processValueDescription (vd : Parsetree.value_description ) =
56
- symbols := ( vd.pval_name.txt, vd.pval_loc, Variable ) :: ! symbols
63
+ addSymbol vd.pval_name.txt vd.pval_loc Variable
57
64
in
58
65
let processModuleBinding (mb : Parsetree.module_binding ) =
59
- symbols := ( mb.pmb_name.txt, mb.pmb_loc, Module ) :: ! symbols
66
+ addSymbol mb.pmb_name.txt mb.pmb_loc Module
60
67
in
61
68
let processModuleDeclaration (md : Parsetree.module_declaration ) =
62
- symbols := ( md.pmd_name.txt, md.pmd_loc, Module ) :: ! symbols
69
+ addSymbol md.pmd_name.txt md.pmd_loc Module
63
70
in
64
71
let processExtensionConstructor (et : Parsetree.extension_constructor ) =
65
- symbols := ( et.pext_name.txt, et.pext_loc, Constructor ) :: ! symbols
72
+ addSymbol et.pext_name.txt et.pext_loc Constructor
66
73
in
67
74
let value_binding (iterator : Ast_iterator.iterator )
68
75
(vb : Parsetree.value_binding ) =
69
76
(match vb.pvb_pat.ppat_desc with
70
77
| Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt} } , _ ) ->
71
- symbols := ( txt, vb.pvb_loc, exprKind vb.pvb_expr) :: ! symbols
78
+ addSymbol txt vb.pvb_loc ( exprKind vb.pvb_expr)
72
79
| _ -> () );
73
80
Ast_iterator. default_iterator.value_binding iterator vb
74
81
in
75
82
let expr (iterator : Ast_iterator.iterator ) (e : Parsetree.expression ) =
76
83
(match e.pexp_desc with
77
84
| Pexp_letmodule ({txt} , modExpr , _ ) ->
78
- symbols :=
79
- (txt, {e.pexp_loc with loc_end = modExpr.pmod_loc.loc_end}, Module )
80
- :: ! symbols
85
+ addSymbol txt {e.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} Module
81
86
| Pexp_letexception (ec , _ ) -> processExtensionConstructor ec
82
87
| _ -> () );
83
88
Ast_iterator. default_iterator.expr iterator e
@@ -134,12 +139,57 @@ let command ~path =
134
139
let parser = Res_driver. parsingEngine.parseInterface ~for Printer:false in
135
140
let {Res_driver. parsetree = signature} = parser ~filename: path in
136
141
iterator.signature iterator signature |> ignore);
137
- let result =
138
- ! symbols
139
- |> List. rev_map (fun (name , loc , kind ) ->
140
- let range = Utils. cmtLocToRange loc in
141
- Protocol. stringifyDocumentSymbolItem
142
- {name; range; selectionRange = range; kind = kindNumber kind})
143
- |> String. concat " ,\n "
144
- in
145
- print_endline (" [\n " ^ result ^ " \n ]" )
142
+ let isInside
143
+ ({
144
+ range =
145
+ {
146
+ start = {line = sl1 ; character = sc1 } ;
147
+ end_ = {line = el1 ; character = ec1 } ;
148
+ } ;
149
+ } :
150
+ Protocol. documentSymbolItem )
151
+ ({
152
+ range =
153
+ {
154
+ start = {line = sl2 ; character = sc2 } ;
155
+ end_ = {line = el2 ; character = ec2 } ;
156
+ } ;
157
+ } :
158
+ Protocol. documentSymbolItem ) =
159
+ (sl1 > sl2 || (sl1 = sl2 && sc1 > = sc2))
160
+ && (el1 < el2 || (el1 = el2 && ec1 < = ec2))
161
+ in
162
+ let compareSymbol (s1 : Protocol.documentSymbolItem )
163
+ (s2 : Protocol.documentSymbolItem ) =
164
+ let n = compare s1.range.start.line s2.range.start.line in
165
+ if n <> 0 then n
166
+ else
167
+ let n = compare s1.range.start.character s2.range.start.character in
168
+ if n <> 0 then n
169
+ else
170
+ let n = compare s1.range.end_.line s2.range.end_.line in
171
+ if n <> 0 then n
172
+ else compare s1.range.end_.character s2.range.end_.character
173
+ in
174
+ let rec addSymbolToChildren ~symbol children =
175
+ match children with
176
+ | [] -> [symbol]
177
+ | last :: rest ->
178
+ if isInside symbol last then
179
+ let newLast =
180
+ {last with children = last.children |> addSymbolToChildren ~symbol }
181
+ in
182
+ newLast :: rest
183
+ else symbol :: children
184
+ in
185
+ let rec addSortedSymbolsToChildren ~sortedSymbols children =
186
+ match sortedSymbols with
187
+ | [] -> children
188
+ | firstSymbol :: rest ->
189
+ children
190
+ |> addSymbolToChildren ~symbol: firstSymbol
191
+ |> addSortedSymbolsToChildren ~sorted Symbols:rest
192
+ in
193
+ let sortedSymbols = ! symbols |> List. sort compareSymbol in
194
+ let symbolsWithChildren = [] |> addSortedSymbolsToChildren ~sorted Symbols in
195
+ print_endline (Protocol. stringifyDocumentSymbolItems symbolsWithChildren)
0 commit comments