File : sa_messages.adb
1 ------------------------------------------------------------------------------
2 -- C O D E P E E R / S P A R K --
3 -- --
4 -- Copyright (C) 2015-2016, 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
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;