1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283 | with Ada.Characters.Handling;
with Ada.Text_IO; use Ada.Text_IO;
with GNATCOLL.Opt_Parse;
with GNATCOLL.Strings;
with GNATCOLL.VFS;
with Langkit_Support.Text;
with Libadalang.Analysis;
with Libadalang.Common;
with Libadalang.Helpers;
with Libadalang.Iterators;
with Put_Title;
procedure Navigate is
package LAL renames Libadalang.Analysis;
package LALCO renames Libadalang.Common;
package LALIT renames Libadalang.Iterators;
package X renames GNATCOLL.Strings;
type Enabled_Kinds_Type is array (LALCO.Ada_Node_Kind_Type) of Boolean;
All_Kinds : constant Enabled_Kinds_Type := (others => True);
function String_To_Kinds (List : String) return Enabled_Kinds_Type;
procedure Process_File
(Context : Libadalang.Helpers.App_Job_Context; Unit : LAL.Analysis_Unit);
package App is new Libadalang.Helpers.App
(Name => "navigate",
Description => "Navigate between AST nodes (spec/body/...).",
Process_Unit => Process_File);
package Args is
use GNATCOLL.Opt_Parse;
package Kinds is new Parse_Option
(App.Args.Parser, "-k", "--kinds",
"Comma-separated list of AST node kind names, like"
& " ""Ada_Subp_Body,Ada_Package_Decl"". This will filter the"
& " nodes on which we navigate.",
Enabled_Kinds_Type,
Default_Val => All_Kinds,
Convert => String_To_Kinds);
end Args;
function To_Lower (S : String) return String
renames Ada.Characters.Handling.To_Lower;
function Is_Navigation_Disabled (N : LAL.Ada_Node) return Boolean;
procedure Print_Navigation
(Part_Name : String; Orig, Dest : LAL.Ada_Node'Class);
function Basename (Filename : String) return String;
-- Return the base name of the Filename path
--------------
-- Basename --
--------------
function Basename (Filename : String) return String is
use GNATCOLL.VFS;
begin
return +Create (+Filename).Base_Name;
end Basename;
------------------
-- Process_File --
------------------
procedure Process_File
(Context : Libadalang.Helpers.App_Job_Context; Unit : LAL.Analysis_Unit)
is
pragma Unreferenced (Context);
use GNATCOLL.VFS;
At_Least_Once : Boolean := False;
function Filter (N : LAL.Ada_Node) return Boolean is
(Args.Kinds.Get (N.Kind) and then not Is_Navigation_Disabled (N));
begin
Put_Title ('#', +Create (+Unit.Get_Filename).Base_Name);
if Unit.Has_Diagnostics then
for D of Unit.Diagnostics loop
Put_Line (Unit.Format_GNU_Diagnostic (D));
end loop;
New_Line;
return;
end if;
for Node of LALIT.Find (Unit.Root, Filter'Access).Consume loop
declare
Processed_Something : Boolean := True;
begin
case Node.Kind is
-- Bodies
when LALCO.Ada_Body_Node =>
Print_Navigation
("Body previous part", Node,
Node.As_Body_Node.P_Previous_Part);
Print_Navigation
("Decl", Node,
Node.As_Body_Node.P_Decl_Part);
case Node.Kind is
when LALCO.Ada_Package_Body_Stub =>
Print_Navigation
("Body", Node,
Node.As_Package_Body_Stub.P_Body_Part_For_Decl);
when others => null;
end case;
-- Packages
when LALCO.Ada_Base_Type_Decl =>
Print_Navigation
("Type previous part", Node,
Node.As_Base_Type_Decl.P_Previous_Part);
case Node.Kind is
when LALCO.Ada_Protected_Type_Decl =>
Print_Navigation
("Protected decl next part", Node,
Node.As_Basic_Decl.P_Next_Part_For_Decl);
Print_Navigation
("Protected decl body part", Node,
Node.As_Basic_Decl.P_Body_Part_For_Decl);
when others =>
-- Protected type decls don't have a type next part
Print_Navigation
("Type next part", Node,
Node.As_Base_Type_Decl.P_Next_Part);
end case;
when LALCO.Ada_Base_Package_Decl =>
Print_Navigation
("Body", Node,
Node.As_Base_Package_Decl.P_Body_Part);
when LALCO.Ada_Generic_Package_Decl =>
Print_Navigation
("Body", Node,
Node.As_Generic_Package_Decl.P_Body_Part);
-- Subprograms
when LALCO.Ada_Classic_Subp_Decl =>
Print_Navigation
("Body", Node, Node.As_Classic_Subp_Decl.P_Body_Part);
when LALCO.Ada_Generic_Subp_Decl =>
Print_Navigation
("Body", Node,
Node.As_Generic_Subp_Decl.P_Body_Part);
when others =>
Processed_Something := False;
end case;
At_Least_Once := At_Least_Once or else Processed_Something;
exception
when LALCO.Property_Error =>
Put_Line ("Error when processing " & Node.Image);
At_Least_Once := True;
end;
end loop;
if not At_Least_Once then
Put_Line ("<no node to process>");
end if;
New_Line;
end Process_File;
----------------------
-- Print_Navigation --
----------------------
procedure Print_Navigation
(Part_Name : String; Orig, Dest : LAL.Ada_Node'Class) is
begin
if Dest.Is_Null then
Put_Line (Orig.Image & " has no " & To_Lower (Part_Name));
else
Put_Line
(Part_Name & " of " & Orig.Image & " is " & Dest.Image
& " [" & Basename (Dest.Unit.Get_Filename) & "]");
end if;
end Print_Navigation;
------------------
-- Decode_Kinds --
------------------
function String_To_Kinds (List : String) return Enabled_Kinds_Type is
Enabled_Kinds : Enabled_Kinds_Type := (others => False);
Names : constant X.XString_Array := X.To_XString (List).Split (",");
begin
for Name of Names loop
if Name.Length /= 0 then
begin
declare
Kind : constant LALCO.Ada_Node_Kind_Type :=
LALCO.Ada_Node_Kind_Type'Value (X.To_String (Name));
begin
Enabled_Kinds (Kind) := True;
end;
exception
when Constraint_Error =>
raise GNATCOLL.Opt_Parse.Opt_Parse_Error
with "invalid kind name: " & X.To_String (Name);
end;
end if;
end loop;
return Enabled_Kinds;
end String_To_Kinds;
----------------------------
-- Is_Navigation_Disabled --
----------------------------
function Is_Navigation_Disabled (N : LAL.Ada_Node) return Boolean is
function Lowercase_Name (Id : LAL.Identifier) return String is
(To_Lower (Langkit_Support.Text.Image (Id.Text)));
function Has_Disable_Navigation
(Aspects : LAL.Aspect_Spec) return Boolean;
----------------------------
-- Has_Disable_Navigation --
----------------------------
function Has_Disable_Navigation
(Aspects : LAL.Aspect_Spec) return Boolean
is
use type LALCO.Ada_Node_Kind_Type;
begin
if Aspects.Is_Null then
return False;
end if;
for Child of LAL.Ada_Node_Array'(Aspects.F_Aspect_Assocs.Children)
loop
declare
Assoc : constant LAL.Aspect_Assoc := Child.As_Aspect_Assoc;
begin
if Assoc.F_Id.Kind = LALCO.Ada_Identifier then
declare
Id : constant LAL.Identifier := Assoc.F_Id.As_Identifier;
begin
return Lowercase_Name (Id) = "disable_navigation";
end;
end if;
end;
end loop;
return False;
end Has_Disable_Navigation;
begin
case N.Kind is
when LALCO.Ada_Base_Package_Decl =>
return Has_Disable_Navigation (N.As_Base_Package_Decl.F_Aspects);
when others =>
return False;
end case;
end Is_Navigation_Disabled;
begin
App.Run;
Put_Line ("Done.");
end Navigate;
|