Skip to content

Commit ae3f519

Browse files
reznikmmreznikmm
committed
Add Prepare_Type_Hierarchy package.
Refs #360
1 parent 8ab0951 commit ae3f519

5 files changed

+203
-0
lines changed

Diff for: ‎liblsp_3_17/source/lsp-constants.ads

+8
Original file line numberDiff line numberDiff line change
@@ -86,6 +86,14 @@ package LSP.Constants is
8686
return LSP.Structures.typeDefinitionProvider_OfServerCapabilities_Optional
8787
is (Is_Set => True, Value => True);
8888

89+
function True
90+
return LSP.Structures.typeHierarchyProvider_OfServerCapabilities
91+
is (Kind => LSP.Structures.Variant_1, Variant_1 => True);
92+
93+
function True
94+
return LSP.Structures.typeHierarchyProvider_OfServerCapabilities_Optional
95+
is (Is_Set => True, Value => True);
96+
8997
function True return LSP.Structures.Boolean_Or_WorkspaceSymbolOptions
9098
is (Is_Boolean => True, Boolean => True);
9199

Diff for: ‎source/ada/lsp-ada_client_capabilities.adb

+1
Original file line numberDiff line numberDiff line change
@@ -423,6 +423,7 @@ package body LSP.Ada_Client_Capabilities is
423423
Result.implementationProvider := LSP.Constants.True;
424424
Result.referencesProvider := LSP.Constants.True;
425425
Result.typeDefinitionProvider := LSP.Constants.True;
426+
Result.typeHierarchyProvider := LSP.Constants.True;
426427
Result.workspaceSymbolProvider := LSP.Constants.True;
427428

428429
Result.completionProvider :=

Diff for: ‎source/ada/lsp-ada_driver.adb

+10
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ with LSP.Ada_Did_Change_Document;
4747
with LSP.Ada_Execute_Command;
4848
with LSP.Ada_Folding_Range;
4949
with LSP.Ada_Hover;
50+
with LSP.Ada_Prepare_Type_Hierarchy;
5051
with LSP.Ada_References;
5152
with LSP.Ada_Handlers;
5253
with LSP.Ada_Handlers.Executables_Commands;
@@ -97,6 +98,7 @@ with LSP.Server_Requests.ExecuteCommand;
9798
with LSP.Server_Requests.FoldingRange;
9899
with LSP.Server_Requests.Hover;
99100
with LSP.Server_Requests.Initialize;
101+
with LSP.Server_Requests.PrepareTypeHierarchy;
100102
with LSP.Server_Requests.References;
101103
with LSP.Server_Requests.Tokens_Full;
102104
with LSP.Server_Requests.Tokens_Range;
@@ -239,6 +241,10 @@ procedure LSP.Ada_Driver is
239241
LSP.Ada_Tokens_Range.Ada_Tokens_Range_Handler
240242
(Ada_Handler'Unchecked_Access);
241243

244+
Ada_Prepare_Type_Hierarchy_Handler : aliased
245+
LSP.Ada_Prepare_Type_Hierarchy.Ada_Prepare_Type_Hierarchy_Handler
246+
(Ada_Handler'Unchecked_Access);
247+
242248
Ada_Fence_Message_Handler : aliased
243249
LSP.Default_Message_Handlers.Default_Message_Handler;
244250
-- A shared handler with Fense priority
@@ -530,6 +536,10 @@ begin
530536
(LSP.Server_Requests.Tokens_Range.Request'Tag,
531537
Ada_Tokens_Range_Handler'Unchecked_Access);
532538

539+
Server.Register_Handler
540+
(LSP.Server_Requests.PrepareTypeHierarchy.Request'Tag,
541+
Ada_Prepare_Type_Hierarchy_Handler'Unchecked_Access);
542+
533543
Server.Register_Handler
534544
(LSP.Server_Requests.References.Request'Tag,
535545
Ada_References_Handler'Unchecked_Access);

Diff for: ‎source/ada/lsp-ada_prepare_type_hierarchy.adb

+146
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,146 @@
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 Libadalang;
19+
with Libadalang.Analysis;
20+
with Libadalang.Common;
21+
22+
with VSS.Strings;
23+
24+
with LSP.Ada_Context_Sets;
25+
with LSP.Ada_Request_Jobs;
26+
with LSP.Client_Message_Receivers;
27+
with LSP.Server_Request_Jobs;
28+
with LSP.Server_Requests.PrepareTypeHierarchy;
29+
with LSP.Structures;
30+
with LSP.Utils;
31+
32+
package body LSP.Ada_Prepare_Type_Hierarchy is
33+
34+
type Ada_Prepare_Type_Hierarchy_Job
35+
(Parent : not null access constant Ada_Prepare_Type_Hierarchy_Handler) is
36+
limited new LSP.Ada_Request_Jobs.Ada_Request_Job
37+
(Priority => LSP.Server_Jobs.Low)
38+
with null record;
39+
40+
overriding procedure Execute_Ada_Request
41+
(Self : in out Ada_Prepare_Type_Hierarchy_Job;
42+
Client :
43+
in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class;
44+
Status : out LSP.Server_Jobs.Execution_Status);
45+
-- Execute PrepareTypeHierarchy request
46+
47+
function Skip_Subtypes
48+
(Tipe : Libadalang.Analysis.Base_Type_Decl)
49+
return Libadalang.Analysis.Base_Type_Decl;
50+
51+
-------------------------
52+
-- Execute_Ada_Request --
53+
-------------------------
54+
55+
overriding procedure Execute_Ada_Request
56+
(Self : in out Ada_Prepare_Type_Hierarchy_Job;
57+
Client :
58+
in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class;
59+
Status : out LSP.Server_Jobs.Execution_Status)
60+
is
61+
Message : LSP.Server_Requests.PrepareTypeHierarchy.Request
62+
renames LSP.Server_Requests.PrepareTypeHierarchy.Request
63+
(Self.Message.all);
64+
65+
Context : constant LSP.Ada_Context_Sets.Context_Access :=
66+
Self.Parent.Context.Get_Best_Context (Message.Params.textDocument.uri);
67+
68+
Response : LSP.Structures.TypeHierarchyItem_Vector_Or_Null;
69+
70+
Name : constant Libadalang.Analysis.Defining_Name :=
71+
Self.Parent.Context.Imprecise_Resolve_Name
72+
(Context.all, Message.Params);
73+
-- Canonical defining name
74+
75+
Type_Decl : constant Libadalang.Analysis.Base_Type_Decl :=
76+
(if not Name.Is_Null
77+
and then not Name.P_Basic_Decl.Is_Null
78+
and then Name.P_Basic_Decl.Kind in
79+
Libadalang.Common.Ada_Base_Type_Decl
80+
then Skip_Subtypes (Name.P_Basic_Decl.As_Base_Type_Decl)
81+
else Libadalang.Analysis.No_Base_Type_Decl);
82+
83+
Loc : LSP.Structures.Location;
84+
Decl : Libadalang.Analysis.Basic_Decl;
85+
Item : LSP.Structures.TypeHierarchyItem;
86+
begin
87+
if not Type_Decl.Is_Null then
88+
-- We have got a type, return its the very first declaration "part"
89+
Decl := Type_Decl.P_Canonical_Part;
90+
91+
Loc := Self.Parent.Context.To_LSP_Location (Decl);
92+
93+
Item :=
94+
(name => VSS.Strings.To_Virtual_String
95+
(Decl.P_Defining_Name.Text),
96+
kind => LSP.Utils.Get_Decl_Kind (Decl),
97+
tags => <>,
98+
detail => LSP.Utils.Node_Location_Image
99+
(Decl.P_Defining_Name),
100+
uri => Loc.uri,
101+
a_range => Loc.a_range,
102+
selectionRange => Self.Parent.Context.To_LSP_Location
103+
(Decl.P_Defining_Name).a_range,
104+
data => <>);
105+
106+
Response.Append (Item);
107+
end if;
108+
109+
Client.On_PrepareTypeHierarchy_Response (Message.Id, Response);
110+
Status := LSP.Server_Jobs.Done;
111+
end Execute_Ada_Request;
112+
113+
----------------
114+
-- Create_Job --
115+
----------------
116+
117+
overriding function Create_Job
118+
(Self : Ada_Prepare_Type_Hierarchy_Handler;
119+
Message : LSP.Server_Messages.Server_Message_Access)
120+
return LSP.Server_Jobs.Server_Job_Access is
121+
begin
122+
return new Ada_Prepare_Type_Hierarchy_Job'
123+
(Parent => Self'Unchecked_Access,
124+
Request => LSP.Server_Request_Jobs.Request_Access (Message));
125+
end Create_Job;
126+
127+
-------------------
128+
-- Skip_Subtypes --
129+
-------------------
130+
131+
function Skip_Subtypes
132+
(Tipe : Libadalang.Analysis.Base_Type_Decl)
133+
return Libadalang.Analysis.Base_Type_Decl
134+
is
135+
use type Libadalang.Analysis.Base_Type_Decl;
136+
137+
Result : constant Libadalang.Analysis.Base_Type_Decl :=
138+
Tipe.P_Base_Subtype;
139+
begin
140+
return (if Tipe = Result then Tipe else Skip_Subtypes (Result));
141+
exception
142+
when others =>
143+
return Tipe;
144+
end Skip_Subtypes;
145+
146+
end LSP.Ada_Prepare_Type_Hierarchy;

Diff for: ‎source/ada/lsp-ada_prepare_type_hierarchy.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
19+
-- textDocument/prepareTypeHierarchy 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_Prepare_Type_Hierarchy is
27+
28+
type Ada_Prepare_Type_Hierarchy_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_Prepare_Type_Hierarchy_Handler;
35+
Message : LSP.Server_Messages.Server_Message_Access)
36+
return LSP.Server_Jobs.Server_Job_Access;
37+
38+
end LSP.Ada_Prepare_Type_Hierarchy;

0 commit comments

Comments
 (0)