]>
Commit | Line | Data |
---|---|---|
d40800cf PMR |
1 | ------------------------------------------------------------------------------ |
2 | -- C O D E P E E R / S P A R K -- | |
3 | -- -- | |
8d0d46f4 | 4 | -- Copyright (C) 2015-2021, AdaCore -- |
d40800cf PMR |
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 | ||
19 | pragma Ada_2012; | |
20 | ||
21 | with Ada.Directories; use Ada.Directories; | |
22 | with Ada.Strings.Unbounded.Hash; | |
23 | ||
24 | with Ada.Text_IO; use Ada.Text_IO; | |
25 | with GNATCOLL.JSON; use GNATCOLL.JSON; | |
26 | ||
27 | package body SA_Messages is | |
28 | ||
29 | ----------------------- | |
30 | -- Local subprograms -- | |
31 | ----------------------- | |
32 | ||
33 | function "<" (Left, Right : SA_Message) return Boolean is | |
34 | (if Left.Kind /= Right.Kind then | |
35 | Left.Kind < Right.Kind | |
36 | else | |
37 | Left.Kind in Check_Kind | |
38 | and then Left.Check_Result < Right.Check_Result); | |
39 | ||
40 | function "<" (Left, Right : Simple_Source_Location) return Boolean is | |
41 | (if Left.File_Name /= Right.File_Name then | |
42 | Left.File_Name < Right.File_Name | |
43 | elsif Left.Line /= Right.Line then | |
44 | Left.Line < Right.Line | |
45 | else | |
46 | Left.Column < Right.Column); | |
47 | ||
48 | function "<" (Left, Right : Source_Locations) return Boolean is | |
49 | (if Left'Length /= Right'Length then | |
50 | Left'Length < Right'Length | |
51 | elsif Left'Length = 0 then | |
52 | False | |
53 | elsif Left (Left'Last) /= Right (Right'Last) then | |
54 | Left (Left'Last) < Right (Right'Last) | |
55 | else | |
56 | Left (Left'First .. Left'Last - 1) < | |
57 | Right (Right'First .. Right'Last - 1)); | |
58 | ||
59 | function "<" (Left, Right : Source_Location) return Boolean is | |
60 | (Left.Locations < Right.Locations); | |
61 | ||
62 | function Base_Location | |
63 | (Location : Source_Location) return Simple_Source_Location is | |
64 | (Location.Locations (1)); | |
65 | ||
66 | function Hash (Key : SA_Message) return Hash_Type; | |
67 | function Hash (Key : Source_Location) return Hash_Type; | |
68 | ||
69 | --------- | |
70 | -- "<" -- | |
71 | --------- | |
72 | ||
73 | function "<" (Left, Right : Message_And_Location) return Boolean is | |
74 | (if Left.Message = Right.Message | |
75 | then Left.Location < Right.Location | |
76 | else Left.Message < Right.Message); | |
77 | ||
78 | ------------ | |
79 | -- Column -- | |
80 | ------------ | |
81 | ||
82 | function Column (Location : Source_Location) return Column_Number is | |
83 | (Base_Location (Location).Column); | |
84 | ||
85 | --------------- | |
86 | -- File_Name -- | |
87 | --------------- | |
88 | ||
89 | function File_Name (Location : Source_Location) return String is | |
90 | (To_String (Base_Location (Location).File_Name)); | |
91 | ||
92 | function File_Name (Location : Source_Location) return Unbounded_String is | |
93 | (Base_Location (Location).File_Name); | |
94 | ||
95 | ------------------------ | |
96 | -- Enclosing_Instance -- | |
97 | ------------------------ | |
98 | ||
99 | function Enclosing_Instance | |
100 | (Location : Source_Location) return Source_Location_Or_Null is | |
101 | (Count => Location.Count - 1, | |
102 | Locations => Location.Locations (2 .. Location.Count)); | |
103 | ||
104 | ---------- | |
105 | -- Hash -- | |
106 | ---------- | |
107 | ||
108 | function Hash (Key : Message_And_Location) return Hash_Type is | |
109 | (Hash (Key.Message) + Hash (Key.Location)); | |
110 | ||
111 | function Hash (Key : SA_Message) return Hash_Type is | |
112 | begin | |
113 | return Result : Hash_Type := | |
114 | Hash_Type'Mod (Message_Kind'Pos (Key.Kind)) | |
115 | do | |
116 | if Key.Kind in Check_Kind then | |
117 | Result := Result + | |
118 | Hash_Type'Mod (SA_Check_Result'Pos (Key.Check_Result)); | |
119 | end if; | |
120 | end return; | |
121 | end Hash; | |
122 | ||
123 | function Hash (Key : Source_Location) return Hash_Type is | |
124 | begin | |
125 | return Result : Hash_Type := Hash_Type'Mod (Key.Count) do | |
126 | for Loc of Key.Locations loop | |
127 | Result := Result + Hash (Loc.File_Name); | |
128 | Result := Result + Hash_Type'Mod (Loc.Line); | |
129 | Result := Result + Hash_Type'Mod (Loc.Column); | |
130 | end loop; | |
131 | end return; | |
132 | end Hash; | |
133 | ||
134 | --------------- | |
135 | -- Iteration -- | |
136 | --------------- | |
137 | ||
138 | function Iteration (Location : Source_Location) return Iteration_Id is | |
139 | (Base_Location (Location).Iteration); | |
140 | ||
141 | ---------- | |
142 | -- Line -- | |
143 | ---------- | |
144 | ||
145 | function Line (Location : Source_Location) return Line_Number is | |
146 | (Base_Location (Location).Line); | |
147 | ||
148 | -------------- | |
149 | -- Location -- | |
150 | -------------- | |
151 | ||
152 | function Location | |
153 | (Item : Message_And_Location) return Source_Location is | |
154 | (Item.Location); | |
155 | ||
156 | ---------- | |
157 | -- Make -- | |
158 | ---------- | |
159 | ||
160 | function Make | |
161 | (File_Name : String; | |
162 | Line : Line_Number; | |
163 | Column : Column_Number; | |
164 | Iteration : Iteration_Id; | |
165 | Enclosing_Instance : Source_Location_Or_Null) return Source_Location | |
166 | is | |
167 | begin | |
168 | return Result : Source_Location | |
169 | (Count => Enclosing_Instance.Count + 1) | |
170 | do | |
171 | Result.Locations (1) := | |
172 | (File_Name => To_Unbounded_String (File_Name), | |
173 | Line => Line, | |
174 | Column => Column, | |
175 | Iteration => Iteration); | |
176 | ||
177 | Result.Locations (2 .. Result.Count) := Enclosing_Instance.Locations; | |
178 | end return; | |
179 | end Make; | |
180 | ||
181 | ------------------ | |
182 | -- Make_Msg_Loc -- | |
183 | ------------------ | |
184 | ||
185 | function Make_Msg_Loc | |
186 | (Msg : SA_Message; | |
187 | Loc : Source_Location) return Message_And_Location | |
188 | is | |
189 | begin | |
190 | return Message_And_Location'(Count => Loc.Count, | |
191 | Message => Msg, | |
192 | Location => Loc); | |
193 | end Make_Msg_Loc; | |
194 | ||
195 | ------------- | |
196 | -- Message -- | |
197 | ------------- | |
198 | ||
199 | function Message (Item : Message_And_Location) return SA_Message is | |
200 | (Item.Message); | |
201 | ||
202 | package Field_Names is | |
203 | ||
204 | -- A Source_Location value is represented in JSON as a two or three | |
205 | -- field value having fields Message_Kind (a string) and Locations (an | |
206 | -- array); if the Message_Kind indicates a check kind, then a third | |
207 | -- field is present: Check_Result (a string). The element type of the | |
208 | -- Locations array is a value having at least 4 fields: | |
209 | -- File_Name (a string), Line (an integer), Column (an integer), | |
210 | -- and Iteration_Kind (an integer); if the Iteration_Kind field | |
211 | -- has the value corresponding to the enumeration literal Numbered, | |
212 | -- then two additional integer fields are present, Iteration_Number | |
213 | -- and Iteration_Of_Total. | |
214 | ||
215 | Check_Result : constant String := "Check_Result"; | |
216 | Column : constant String := "Column"; | |
217 | File_Name : constant String := "File_Name"; | |
218 | Iteration_Kind : constant String := "Iteration_Kind"; | |
219 | Iteration_Number : constant String := "Iteration_Number"; | |
220 | Iteration_Of_Total : constant String := "Iteration_Total"; | |
221 | Line : constant String := "Line"; | |
222 | Locations : constant String := "Locations"; | |
223 | Message_Kind : constant String := "Message_Kind"; | |
224 | Messages : constant String := "Messages"; | |
225 | end Field_Names; | |
226 | ||
227 | package body Writing is | |
228 | File : File_Type; | |
229 | -- The file to which output will be written (in Close, not in Write) | |
230 | ||
231 | Messages : JSON_Array; | |
232 | -- Successive calls to Write append messages to this list | |
233 | ||
234 | ----------------------- | |
235 | -- Local subprograms -- | |
236 | ----------------------- | |
237 | ||
238 | function To_JSON_Array | |
239 | (Locations : Source_Locations) return JSON_Array; | |
240 | -- Represent a Source_Locations array as a JSON_Array | |
241 | ||
242 | function To_JSON_Value | |
243 | (Location : Simple_Source_Location) return JSON_Value; | |
244 | -- Represent a Simple_Source_Location as a JSON_Value | |
245 | ||
246 | ----------- | |
247 | -- Close -- | |
248 | ----------- | |
249 | ||
250 | procedure Close is | |
251 | Value : constant JSON_Value := Create_Object; | |
252 | ||
253 | begin | |
254 | -- only one field for now | |
255 | Set_Field (Value, Field_Names.Messages, Messages); | |
256 | Put_Line (File, Write (Item => Value, Compact => False)); | |
257 | Clear (Messages); | |
258 | Close (File => File); | |
259 | end Close; | |
260 | ||
261 | ------------- | |
262 | -- Is_Open -- | |
263 | ------------- | |
264 | ||
265 | function Is_Open return Boolean is (Is_Open (File)); | |
266 | ||
267 | ---------- | |
268 | -- Open -- | |
269 | ---------- | |
270 | ||
271 | procedure Open (File_Name : String) is | |
272 | begin | |
273 | Create (File => File, Mode => Out_File, Name => File_Name); | |
274 | Clear (Messages); | |
275 | end Open; | |
276 | ||
277 | ------------------- | |
278 | -- To_JSON_Array -- | |
279 | ------------------- | |
280 | ||
281 | function To_JSON_Array | |
282 | (Locations : Source_Locations) return JSON_Array | |
283 | is | |
284 | begin | |
285 | return Result : JSON_Array := Empty_Array do | |
286 | for Location of Locations loop | |
287 | Append (Result, To_JSON_Value (Location)); | |
288 | end loop; | |
289 | end return; | |
290 | end To_JSON_Array; | |
291 | ||
292 | ------------------- | |
293 | -- To_JSON_Value -- | |
294 | ------------------- | |
295 | ||
296 | function To_JSON_Value | |
297 | (Location : Simple_Source_Location) return JSON_Value | |
298 | is | |
299 | begin | |
300 | return Result : constant JSON_Value := Create_Object do | |
301 | Set_Field (Result, Field_Names.File_Name, Location.File_Name); | |
302 | Set_Field (Result, Field_Names.Line, Integer (Location.Line)); | |
303 | Set_Field (Result, Field_Names.Column, Integer (Location.Column)); | |
304 | Set_Field (Result, Field_Names.Iteration_Kind, Integer'( | |
305 | Iteration_Kind'Pos (Location.Iteration.Kind))); | |
306 | ||
307 | if Location.Iteration.Kind = Numbered then | |
308 | Set_Field (Result, Field_Names.Iteration_Number, | |
309 | Location.Iteration.Number); | |
310 | Set_Field (Result, Field_Names.Iteration_Of_Total, | |
311 | Location.Iteration.Of_Total); | |
312 | end if; | |
313 | end return; | |
314 | end To_JSON_Value; | |
315 | ||
316 | ----------- | |
317 | -- Write -- | |
318 | ----------- | |
319 | ||
320 | procedure Write (Message : SA_Message; Location : Source_Location) is | |
321 | Value : constant JSON_Value := Create_Object; | |
322 | ||
323 | begin | |
324 | Set_Field (Value, Field_Names.Message_Kind, Message.Kind'Img); | |
325 | ||
326 | if Message.Kind in Check_Kind then | |
327 | Set_Field | |
328 | (Value, Field_Names.Check_Result, Message.Check_Result'Img); | |
329 | end if; | |
330 | ||
331 | Set_Field | |
332 | (Value, Field_Names.Locations, To_JSON_Array (Location.Locations)); | |
333 | Append (Messages, Value); | |
334 | end Write; | |
335 | end Writing; | |
336 | ||
337 | package body Reading is | |
338 | File : File_Type; | |
339 | -- The file from which messages are read (in Open, not in Read) | |
340 | ||
341 | Messages : JSON_Array; | |
342 | -- The list of messages that were read in from File | |
343 | ||
344 | Next_Index : Positive; | |
345 | -- The index of the message in Messages which will be returned by the | |
346 | -- next call to Get. | |
347 | ||
348 | Parse_Full_Path : Boolean := True; | |
349 | -- if the full path or only the base name of the file should be parsed | |
350 | ||
351 | ----------- | |
352 | -- Close -- | |
353 | ----------- | |
354 | ||
355 | procedure Close is | |
356 | begin | |
357 | Clear (Messages); | |
358 | Close (File); | |
359 | end Close; | |
360 | ||
361 | ---------- | |
362 | -- Done -- | |
363 | ---------- | |
364 | ||
365 | function Done return Boolean is (Next_Index > Length (Messages)); | |
366 | ||
367 | --------- | |
368 | -- Get -- | |
369 | --------- | |
370 | ||
371 | function Get return Message_And_Location is | |
372 | Value : constant JSON_Value := Get (Messages, Next_Index); | |
373 | ||
374 | function Get_Message (Kind : Message_Kind) return SA_Message; | |
375 | -- Return SA_Message of given kind, filling in any non-discriminant | |
376 | -- by reading from Value. | |
377 | ||
378 | function Make | |
379 | (Location : Source_Location; | |
380 | Message : SA_Message) return Message_And_Location; | |
381 | -- Constructor | |
382 | ||
383 | function To_Location | |
384 | (Encoded : JSON_Array; | |
385 | Full_Path : Boolean) return Source_Location; | |
386 | -- Decode a Source_Location from JSON_Array representation | |
387 | ||
388 | function To_Simple_Location | |
389 | (Encoded : JSON_Value; | |
390 | Full_Path : Boolean) return Simple_Source_Location; | |
391 | -- Decode a Simple_Source_Location from JSON_Value representation | |
392 | ||
393 | ----------------- | |
394 | -- Get_Message -- | |
395 | ----------------- | |
396 | ||
397 | function Get_Message (Kind : Message_Kind) return SA_Message is | |
398 | begin | |
399 | -- If we had AI12-0086, then we could use aggregates here (which | |
400 | -- would be better than field-by-field assignment for the usual | |
401 | -- maintainability reasons). But we don't, so we won't. | |
402 | ||
403 | return Result : SA_Message (Kind => Kind) do | |
404 | if Kind in Check_Kind then | |
405 | Result.Check_Result := | |
406 | SA_Check_Result'Value | |
407 | (Get (Value, Field_Names.Check_Result)); | |
408 | end if; | |
409 | end return; | |
410 | end Get_Message; | |
411 | ||
412 | ---------- | |
413 | -- Make -- | |
414 | ---------- | |
415 | ||
416 | function Make | |
417 | (Location : Source_Location; | |
418 | Message : SA_Message) return Message_And_Location | |
419 | is | |
420 | (Count => Location.Count, Message => Message, Location => Location); | |
421 | ||
422 | ----------------- | |
423 | -- To_Location -- | |
424 | ----------------- | |
425 | ||
426 | function To_Location | |
427 | (Encoded : JSON_Array; | |
428 | Full_Path : Boolean) return Source_Location is | |
429 | begin | |
430 | return Result : Source_Location (Count => Length (Encoded)) do | |
431 | for I in Result.Locations'Range loop | |
432 | Result.Locations (I) := | |
433 | To_Simple_Location (Get (Encoded, I), Full_Path); | |
434 | end loop; | |
435 | end return; | |
436 | end To_Location; | |
437 | ||
438 | ------------------------ | |
439 | -- To_Simple_Location -- | |
440 | ------------------------ | |
441 | ||
442 | function To_Simple_Location | |
443 | (Encoded : JSON_Value; | |
444 | Full_Path : Boolean) return Simple_Source_Location | |
445 | is | |
446 | function Get_Iteration_Id | |
447 | (Kind : Iteration_Kind) return Iteration_Id; | |
448 | -- Given the discriminant for an Iteration_Id value, return the | |
449 | -- entire value. | |
450 | ||
451 | ---------------------- | |
452 | -- Get_Iteration_Id -- | |
453 | ---------------------- | |
454 | ||
455 | function Get_Iteration_Id (Kind : Iteration_Kind) | |
456 | return Iteration_Id | |
457 | is | |
458 | begin | |
459 | -- Initialize non-discriminant fields, if any | |
460 | ||
461 | return Result : Iteration_Id (Kind => Kind) do | |
462 | if Kind = Numbered then | |
463 | Result := | |
464 | (Kind => Numbered, | |
465 | Number => | |
466 | Get (Encoded, Field_Names.Iteration_Number), | |
467 | Of_Total => | |
468 | Get (Encoded, Field_Names.Iteration_Of_Total)); | |
469 | end if; | |
470 | end return; | |
471 | end Get_Iteration_Id; | |
472 | ||
473 | -- Local variables | |
474 | ||
475 | FN : constant Unbounded_String := | |
476 | Get (Encoded, Field_Names.File_Name); | |
477 | ||
478 | -- Start of processing for To_Simple_Location | |
479 | ||
480 | begin | |
481 | return | |
482 | (File_Name => | |
483 | (if Full_Path then | |
484 | FN | |
485 | else | |
486 | To_Unbounded_String (Simple_Name (To_String (FN)))), | |
487 | Line => | |
488 | Line_Number (Integer'(Get (Encoded, Field_Names.Line))), | |
489 | Column => | |
490 | Column_Number (Integer'(Get (Encoded, Field_Names.Column))), | |
491 | Iteration => | |
492 | Get_Iteration_Id | |
493 | (Kind => Iteration_Kind'Val (Integer'(Get | |
494 | (Encoded, Field_Names.Iteration_Kind))))); | |
495 | end To_Simple_Location; | |
496 | ||
497 | -- Start of processing for Get | |
498 | ||
499 | begin | |
500 | Next_Index := Next_Index + 1; | |
501 | ||
502 | return Make | |
503 | (Message => | |
504 | Get_Message | |
505 | (Message_Kind'Value (Get (Value, Field_Names.Message_Kind))), | |
506 | Location => | |
507 | To_Location | |
508 | (Get (Value, Field_Names.Locations), Parse_Full_Path)); | |
509 | end Get; | |
510 | ||
511 | ------------- | |
512 | -- Is_Open -- | |
513 | ------------- | |
514 | ||
515 | function Is_Open return Boolean is (Is_Open (File)); | |
516 | ||
517 | ---------- | |
518 | -- Open -- | |
519 | ---------- | |
520 | ||
521 | procedure Open (File_Name : String; Full_Path : Boolean := True) is | |
522 | File_Text : Unbounded_String := Null_Unbounded_String; | |
523 | ||
524 | begin | |
525 | Parse_Full_Path := Full_Path; | |
526 | Open (File => File, Mode => In_File, Name => File_Name); | |
527 | ||
528 | -- File read here, not in Get, but that's an implementation detail | |
529 | ||
530 | while not End_Of_File (File) loop | |
531 | Append (File_Text, Get_Line (File)); | |
532 | end loop; | |
533 | ||
534 | Messages := Get (Read (File_Text), Field_Names.Messages); | |
535 | Next_Index := 1; | |
536 | end Open; | |
537 | end Reading; | |
538 | ||
539 | end SA_Messages; |