Skip to content

Commit 5abf35a

Browse files
reznikmmreznikmm
committed
Rewrite textDocument/declaration as a job
Refs #1141
1 parent cab4204 commit 5abf35a

5 files changed

+308
-160
lines changed

‎source/ada/lsp-ada_declaration.adb

+260
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,260 @@
1+
------------------------------------------------------------------------------
2+
-- Language Server Protocol --
3+
-- --
4+
-- Copyright (C) 2024, AdaCore --
5+
-- --
6+
-- This is free software; you can redistribute it and/or modify it under --
7+
-- terms of the GNU General Public License as published by the Free Soft- --
8+
-- ware Foundation; either version 3, or (at your option) any later ver- --
9+
-- sion. This software is distributed in the hope that it will be useful, --
10+
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
11+
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
12+
-- License for more details. You should have received a copy of the GNU --
13+
-- General Public License distributed with this software; see file --
14+
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
15+
-- of the license. --
16+
------------------------------------------------------------------------------
17+
18+
with GNATCOLL.Traces;
19+
with GNATCOLL.VFS;
20+
21+
with Libadalang.Analysis;
22+
with Libadalang.Common;
23+
24+
with Laltools.Common;
25+
26+
with LSP.Ada_Context_Sets;
27+
with LSP.Ada_Handlers.Locations;
28+
with LSP.Client_Message_Receivers;
29+
with LSP.Enumerations;
30+
with LSP.Locations;
31+
with LSP.Server_Request_Jobs;
32+
with LSP.Server_Requests.Declaration;
33+
with LSP.Structures;
34+
35+
package body LSP.Ada_Declaration is
36+
37+
subtype AlsReferenceKind_Array is LSP.Structures.AlsReferenceKind_Set;
38+
39+
function Is_Parent return AlsReferenceKind_Array is
40+
([LSP.Enumerations.parent => True, others => False]);
41+
42+
function Is_Child return AlsReferenceKind_Array is
43+
([LSP.Enumerations.child => True, others => False]);
44+
45+
type Ada_Declaration_Job
46+
(Parent : not null access constant Ada_Declaration_Handler) is limited
47+
new LSP.Server_Request_Jobs.Server_Request_Job
48+
(Priority => LSP.Server_Jobs.High)
49+
with record
50+
Response : LSP.Structures.Location_Vector;
51+
Filter : LSP.Locations.File_Span_Sets.Set;
52+
Contexts : LSP.Ada_Context_Sets.Context_Lists.List;
53+
end record;
54+
55+
type Ada_Declaration_Job_Access is access all Ada_Declaration_Job;
56+
57+
overriding procedure Execute_Request
58+
(Self : in out Ada_Declaration_Job;
59+
Client :
60+
in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class;
61+
Status : out LSP.Server_Jobs.Execution_Status);
62+
63+
function "or"
64+
(Left :
65+
LSP.Structures.AlsDisplayMethodAncestryOnNavigationPolicy_Optional;
66+
Right : LSP.Enumerations.AlsDisplayMethodAncestryOnNavigationPolicy)
67+
return LSP.Enumerations.AlsDisplayMethodAncestryOnNavigationPolicy is
68+
(if Left.Is_Set then Left.Value else Right);
69+
70+
----------------
71+
-- Create_Job --
72+
----------------
73+
74+
overriding function Create_Job
75+
(Self : Ada_Declaration_Handler;
76+
Message : LSP.Server_Messages.Server_Message_Access)
77+
return LSP.Server_Jobs.Server_Job_Access
78+
is
79+
Value : LSP.Server_Requests.Declaration.Request
80+
renames LSP.Server_Requests.Declaration.Request
81+
(Message.all);
82+
83+
File : constant GNATCOLL.VFS.Virtual_File :=
84+
Self.Context.To_File (Value.Params.textDocument.uri);
85+
86+
Result : constant Ada_Declaration_Job_Access :=
87+
new Ada_Declaration_Job'
88+
(Parent => Self'Unchecked_Access,
89+
Request => LSP.Server_Request_Jobs.Request_Access (Message),
90+
others => <>);
91+
begin
92+
Result.Contexts := Self.Context.Contexts_For_File (File);
93+
94+
return LSP.Server_Jobs.Server_Job_Access (Result);
95+
end Create_Job;
96+
97+
---------------------
98+
-- Execute_Request --
99+
---------------------
100+
101+
overriding procedure Execute_Request
102+
(Self : in out Ada_Declaration_Job;
103+
Client :
104+
in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class;
105+
Status : out LSP.Server_Jobs.Execution_Status)
106+
is
107+
use type
108+
LSP.Structures.AlsDisplayMethodAncestryOnNavigationPolicy_Optional;
109+
110+
use all type LSP.Enumerations.AlsDisplayMethodAncestryOnNavigationPolicy;
111+
112+
Message : LSP.Server_Requests.Declaration.Request
113+
renames LSP.Server_Requests.Declaration.Request (Self.Message.all);
114+
115+
Value : LSP.Structures.DeclarationParams renames Message.Params;
116+
117+
Context : LSP.Ada_Context_Sets.Context_Access;
118+
119+
Display_Method_Policy : constant
120+
LSP.Enumerations.AlsDisplayMethodAncestryOnNavigationPolicy :=
121+
Value.alsDisplayMethodAncestryOnNavigation
122+
or
123+
Self.Parent.Context.Get_Configuration.Display_Method_Ancestry_Policy;
124+
125+
Trace : constant GNATCOLL.Traces.Trace_Handle :=
126+
Self.Parent.Context.Get_Trace_Handle;
127+
128+
Name_Node : Libadalang.Analysis.Name;
129+
130+
Definition : Libadalang.Analysis.Defining_Name;
131+
-- A defining name that corresponds to Name_Node
132+
First_Part : Libadalang.Analysis.Defining_Name;
133+
-- "Canonical part" of Definition
134+
Prev_Part : Libadalang.Analysis.Defining_Name;
135+
-- A previous name for Definition
136+
Decl_For_Find_Overrides : Libadalang.Analysis.Basic_Decl :=
137+
Libadalang.Analysis.No_Basic_Decl;
138+
139+
On_Defining_Name : Boolean := False;
140+
-- Set to True if we are on a denfining name node
141+
142+
Ignore : Boolean;
143+
begin
144+
if Self.Contexts.Is_Empty then
145+
-- No more contexts to process, sort and return collected results
146+
LSP.Ada_Handlers.Locations.Sort (Self.Response);
147+
148+
Client.On_Declaration_Response
149+
(Message.Id,
150+
(Kind => LSP.Structures.Variant_1,
151+
Variant_1 => Self.Response));
152+
153+
Status := LSP.Server_Jobs.Done;
154+
155+
return;
156+
else
157+
Status := LSP.Server_Jobs.Continue;
158+
end if;
159+
160+
Context := Self.Contexts.First_Element;
161+
Self.Contexts.Delete_First;
162+
163+
Name_Node := Laltools.Common.Get_Node_As_Name
164+
(Self.Parent.Context.Get_Node_At (Context.all, Value));
165+
166+
if Name_Node.Is_Null then
167+
return;
168+
end if;
169+
170+
-- Check if we are on some defining name
171+
Definition := Laltools.Common.Get_Name_As_Defining (Name_Node);
172+
173+
if Definition.Is_Null then
174+
-- If we aren't on a defining_name already then try to resolve
175+
Definition := Laltools.Common.Resolve_Name (Name_Node, Trace, Ignore);
176+
else
177+
On_Defining_Name := True;
178+
end if;
179+
180+
if Definition.Is_Null then
181+
return; -- Name resolution fails, nothing to do.
182+
end if;
183+
184+
-- Display the method ancestry in three cases:
185+
--
186+
-- . When the preference is set to Always
187+
--
188+
-- . When we are on a usage node (e.g: subprogram call) and if the
189+
-- preference is set to Usage_And_Abstract_Only
190+
--
191+
-- . When we are on a defining name node and if the preference is
192+
-- set to Definition_Only
193+
194+
if Display_Method_Policy = Always
195+
or else (Display_Method_Policy = Usage_And_Abstract_Only
196+
and then not On_Defining_Name)
197+
or else (Display_Method_Policy = Definition_Only
198+
and then On_Defining_Name)
199+
then
200+
First_Part := Laltools.Common.Find_Canonical_Part (Definition, Trace);
201+
202+
Decl_For_Find_Overrides :=
203+
(if First_Part.Is_Null then Definition.P_Basic_Decl
204+
else First_Part.P_Basic_Decl);
205+
end if;
206+
207+
begin
208+
Prev_Part := Definition.P_Previous_Part;
209+
exception
210+
when E : Libadalang.Common.Property_Error =>
211+
Self.Parent.Context.Trace_Exception (E);
212+
Prev_Part := Libadalang.Analysis.No_Defining_Name;
213+
end;
214+
215+
if not Prev_Part.Is_Null then
216+
-- We have found previous part, return it.
217+
Self.Parent.Context.Append_Location
218+
(Self.Response,
219+
Self.Filter,
220+
Prev_Part);
221+
elsif not Definition.Is_Null then
222+
-- No previous part, return definition itself.
223+
Self.Parent.Context.Append_Location
224+
(Self.Response,
225+
Self.Filter,
226+
Definition);
227+
end if;
228+
229+
if not Decl_For_Find_Overrides.Is_Null then
230+
declare
231+
Overridings : constant Libadalang.Analysis.Basic_Decl_Array :=
232+
Context.Find_All_Overrides
233+
(Decl_For_Find_Overrides,
234+
Imprecise_Results => Ignore);
235+
236+
Bases : constant Libadalang.Analysis.Basic_Decl_Array :=
237+
Context.Find_All_Base_Declarations
238+
(Decl_For_Find_Overrides,
239+
Imprecise_Results => Ignore);
240+
begin
241+
for Subp of Bases loop
242+
Self.Parent.Context.Append_Location
243+
(Self.Response,
244+
Self.Filter,
245+
Subp.P_Defining_Name,
246+
Is_Parent);
247+
end loop;
248+
249+
for Subp of Overridings loop
250+
Self.Parent.Context.Append_Location
251+
(Self.Response,
252+
Self.Filter,
253+
Subp.P_Defining_Name,
254+
Is_Child);
255+
end loop;
256+
end;
257+
end if;
258+
end Execute_Request;
259+
260+
end LSP.Ada_Declaration;

‎source/ada/lsp-ada_declaration.ads

+38
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,38 @@
1+
------------------------------------------------------------------------------
2+
-- Language Server Protocol --
3+
-- --
4+
-- Copyright (C) 2024, AdaCore --
5+
-- --
6+
-- This is free software; you can redistribute it and/or modify it under --
7+
-- terms of the GNU General Public License as published by the Free Soft- --
8+
-- ware Foundation; either version 3, or (at your option) any later ver- --
9+
-- sion. This software is distributed in the hope that it will be useful, --
10+
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
11+
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
12+
-- License for more details. You should have received a copy of the GNU --
13+
-- General Public License distributed with this software; see file --
14+
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
15+
-- of the license. --
16+
------------------------------------------------------------------------------
17+
18+
-- This package provides handler and job types for textDocument/declaration
19+
-- requests.
20+
21+
with LSP.Ada_Job_Contexts;
22+
with LSP.Server_Jobs;
23+
with LSP.Server_Message_Handlers;
24+
with LSP.Server_Messages;
25+
26+
package LSP.Ada_Declaration is
27+
28+
type Ada_Declaration_Handler
29+
(Context : not null access LSP.Ada_Job_Contexts.Ada_Job_Context'Class) is
30+
limited new LSP.Server_Message_Handlers.Server_Message_Handler
31+
with null record;
32+
33+
overriding function Create_Job
34+
(Self : Ada_Declaration_Handler;
35+
Message : LSP.Server_Messages.Server_Message_Access)
36+
return LSP.Server_Jobs.Server_Job_Access;
37+
38+
end LSP.Ada_Declaration;

‎source/ada/lsp-ada_driver.adb

+10
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ with GNATCOLL.Utils;
3939

4040
with LSP.Ada_Commands;
4141
with LSP.Ada_Definition;
42+
with LSP.Ada_Declaration;
4243
with LSP.Ada_Did_Change_Configurations;
4344
with LSP.Ada_Did_Change_Document;
4445
with LSP.Ada_Hover;
@@ -78,6 +79,7 @@ with LSP.Secure_Message_Loggers;
7879
with LSP.Server_Notifications.DidChange;
7980
with LSP.Server_Notifications.DidChangeConfiguration;
8081
with LSP.Server_Requests.Definition;
82+
with LSP.Server_Requests.Declaration;
8183
with LSP.Server_Requests.Hover;
8284
with LSP.Server_Requests.References;
8385
with LSP.Servers;
@@ -195,6 +197,10 @@ procedure LSP.Ada_Driver is
195197
Ada_Definition_Handler : aliased LSP.Ada_Definition.Ada_Definition_Handler
196198
(Ada_Handler'Unchecked_Access);
197199

200+
Ada_Declaration_Handler : aliased
201+
LSP.Ada_Declaration.Ada_Declaration_Handler
202+
(Ada_Handler'Unchecked_Access);
203+
198204
GPR_Did_Change_Doc_Handler : aliased
199205
LSP.GPR_Did_Change_Document.GPR_Did_Change_Handler
200206
(GPR_Handler'Unchecked_Access);
@@ -411,6 +417,10 @@ begin
411417
(LSP.Server_Requests.Definition.Request'Tag,
412418
Ada_Definition_Handler'Unchecked_Access);
413419

420+
Server.Register_Handler
421+
(LSP.Server_Requests.Declaration.Request'Tag,
422+
Ada_Declaration_Handler'Unchecked_Access);
423+
414424
Server.Register_Handler
415425
(LSP.Server_Requests.References.Request'Tag,
416426
Ada_References_Handler'Unchecked_Access);

0 commit comments

Comments
 (0)