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 | --
-- Copyright (C) 2014-2022, AdaCore
-- SPDX-License-Identifier: Apache-2.0
--
with Ada.Characters.Conversions; use Ada.Characters.Conversions;
with Ada.Containers.Vectors;
with Libadalang.Common; use Libadalang.Common;
package body Libadalang.Doc_Utils is
use XStrings;
function Extract_Doc_From
(Token : Token_Reference;
Backwards : Boolean;
Skip_White_Lines : Integer := -1) return Doc_Type;
-- Extract documentation from comments starting at ``Token``. If
-- ``Backwards`` is ``True``, then search for documentation backwards.
-- Skip up to ``Skip_White_Lines`` white lines separating the first doc
-- comment from ``Token``. If ``Skip_White_Lines`` is -1, skip any number
-- of white lines.
--
-- Will raise a ``Property_Error`` if the doc is incorrectly formatted.
----------------------
-- Extract_Doc_From --
----------------------
function Extract_Doc_From
(Token : Token_Reference;
Backwards : Boolean;
Skip_White_Lines : Integer := -1) return Doc_Type
is
Tok : Token_Reference := Token;
T : XStrings.XString;
LF : constant Wide_Wide_Character := To_Wide_Wide_Character (ASCII.LF);
procedure Next_Token;
-- Set Tok to the token after it (if Backwards is False) or to the token
-- before it (if Backwards it True).
procedure Next_Token is
begin
if Backwards then
Tok := Previous (Tok);
else
Tok := Next (Tok);
end if;
end Next_Token;
Ret : Doc_Type;
K : Token_Kind;
package XString_Vectors is new Ada.Containers.Vectors
(Positive, XString);
Doc_Vec : XString_Vectors.Vector;
begin
Next_Token;
-- There is no next token: exit
if Tok = No_Token then
return Ret;
end if;
if Skip_White_Lines /= 0 and then Kind (Data (Tok)) = Ada_Whitespace then
if Skip_White_Lines = -1 then
-- If told to skip all white lines, go ahead
Next_Token;
elsif Skip_White_Lines > 0 then
-- If told to skip a certain number of white lines, verify that
-- the next token indeed contains said number of white lines.
T := To_XString (Common.Text (Tok));
if T.Count (LF) = Skip_White_Lines then
Next_Token;
end if;
end if;
end if;
-- No comment in the direction expected? There is no doc!
if Tok = No_Token or else Kind (Data (Tok)) /= Ada_Comment then
return Ret;
end if;
-- Process as many comments as possible from our starting point,
-- until we find an empty line or anything else than a comment or
-- a whitespace.
while Tok /= No_Token loop
K := Kind (Data (Tok));
case K is
when Ada_Whitespace =>
T := To_XString (Common.Text (Tok));
exit when T.Count (LF) > 1;
when Ada_Comment =>
T := To_XString (Common.Text (Tok));
-- Strip potential CR at the end of the line
if not T.Is_Empty and then T.Get (T.Length) = Chars.CR then
T := T.Slice (1, T.Length - 1);
end if;
-- Strip the "--" from the comment
T := T.Slice (3, T.Length);
-- If this is an annotation then
if T.Starts_With ("%") then
declare
-- Try to split on the ":"
X : constant XString_Array := T.Split (":");
K : constant Wide_Wide_String :=
X (1).Slice (2, X (1).Length).Trim.To_String;
-- ^ Strip % prefix
V : constant Wide_Wide_String :=
(if X'Length < 2
then raise Property_Error
with "Incorrectly formatted docstring"
else X (2).Trim.To_String);
begin
Ret.Annotations.Include (K, V);
end;
else
Doc_Vec.Append (T);
end if;
when others => exit;
end case;
Next_Token;
end loop;
-- Reverse the Doc vector if lines were searched backwards
if Backwards then
Doc_Vec.Reverse_Elements;
end if;
-- Transform the doc vector into a string
declare
Last_Index : constant Natural := Doc_Vec.Last_Index;
Offset : Positive := Positive'Last;
-- Offset for the leftmost first non whitespace char in all the
-- docstring.
begin
for I in Doc_Vec.First_Index .. Last_Index loop
declare
L : XString renames Doc_Vec (I);
Trimmed : XString renames L.Trim;
begin
if Trimmed.Length > 0 then
Offset := Positive'Min
(Offset, L.Length - Trimmed.Length + 1);
end if;
end;
end loop;
for I in Doc_Vec.First_Index .. Last_Index loop
declare
L : XString renames Doc_Vec (I);
begin
-- Check that every character we're going to strip is a white
-- space; else, raise an error.
if not L.Is_Empty
and then (Offset >= L.Length
or else (for some C
of L.Slice (1, Offset - 1)
=> not Is_Space (C)))
then
raise Property_Error with "Incorrectly formatted docstring";
end if;
Ret.Doc.Append (L.Slice (Offset, L.Length));
if I /= Last_Index then
Ret.Doc.Append (LF);
end if;
end;
end loop;
end;
return Ret;
end Extract_Doc_From;
-----------------------
-- Get_Documentation --
-----------------------
function Get_Documentation (Decl : Basic_Decl) return Doc_Type is
Doc : Doc_Type;
begin
if Decl.Kind = Ada_Generic_Package_Internal then
return Get_Documentation (Decl.Parent.As_Basic_Decl);
elsif Decl.Kind in Ada_Base_Package_Decl | Ada_Generic_Package_Decl then
-- Documentation for packages is assumed to appear before the
-- "package" keyword.
Doc := Extract_Doc_From
(Decl.Token_Start, Backwards => True, Skip_White_Lines => -1);
-- If not found and the package is a library unit, search before the
-- prelude.
if Doc.Doc = Null_XString and then Decl.P_Is_Compilation_Unit_Root
then
Doc := Extract_Doc_From
(Decl.Unit.Root.Token_Start,
Backwards => True,
Skip_White_Lines => -1);
end if;
return Doc;
else
-- Documentation for all other entities is assumed to appear after
-- the node representing the entity.
return Extract_Doc_From
(Decl.Token_End, Backwards => False, Skip_White_Lines => 1);
end if;
end Get_Documentation;
end Libadalang.Doc_Utils;
|