1 ------------------------------------------------------------------------------
2 -- C O D E P E E R / S P A R K --
4 -- Copyright (C) 2015-2021, AdaCore --
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 --
17 ------------------------------------------------------------------------------
21 with Ada.Directories; use Ada.Directories;
22 with Ada.Strings.Unbounded.Hash;
24 with Ada.Text_IO; use Ada.Text_IO;
25 with GNATCOLL.JSON; use GNATCOLL.JSON;
27 package body SA_Messages is
29 -----------------------
30 -- Local subprograms --
31 -----------------------
33 function "<" (Left, Right : SA_Message) return Boolean is
34 (if Left.Kind /= Right.Kind then
35 Left.Kind < Right.Kind
37 Left.Kind in Check_Kind
38 and then Left.Check_Result < Right.Check_Result);
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
46 Left.Column < Right.Column);
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
53 elsif Left (Left'Last) /= Right (Right'Last) then
54 Left (Left'Last) < Right (Right'Last)
56 Left (Left'First .. Left'Last - 1) <
57 Right (Right'First .. Right'Last - 1));
59 function "<" (Left, Right : Source_Location) return Boolean is
60 (Left.Locations < Right.Locations);
62 function Base_Location
63 (Location : Source_Location) return Simple_Source_Location is
64 (Location.Locations (1));
66 function Hash (Key : SA_Message) return Hash_Type;
67 function Hash (Key : Source_Location) return Hash_Type;
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);
82 function Column (Location : Source_Location) return Column_Number is
83 (Base_Location (Location).Column);
89 function File_Name (Location : Source_Location) return String is
90 (To_String (Base_Location (Location).File_Name));
92 function File_Name (Location : Source_Location) return Unbounded_String is
93 (Base_Location (Location).File_Name);
95 ------------------------
96 -- Enclosing_Instance --
97 ------------------------
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));
108 function Hash (Key : Message_And_Location) return Hash_Type is
109 (Hash (Key.Message) + Hash (Key.Location));
111 function Hash (Key : SA_Message) return Hash_Type is
113 return Result : Hash_Type :=
114 Hash_Type'Mod (Message_Kind'Pos (Key.Kind))
116 if Key.Kind in Check_Kind then
118 Hash_Type'Mod (SA_Check_Result'Pos (Key.Check_Result));
123 function Hash (Key : Source_Location) return Hash_Type is
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);
138 function Iteration (Location : Source_Location) return Iteration_Id is
139 (Base_Location (Location).Iteration);
145 function Line (Location : Source_Location) return Line_Number is
146 (Base_Location (Location).Line);
153 (Item : Message_And_Location) return Source_Location is
163 Column : Column_Number;
164 Iteration : Iteration_Id;
165 Enclosing_Instance : Source_Location_Or_Null) return Source_Location
168 return Result : Source_Location
169 (Count => Enclosing_Instance.Count + 1)
171 Result.Locations (1) :=
172 (File_Name => To_Unbounded_String (File_Name),
175 Iteration => Iteration);
177 Result.Locations (2 .. Result.Count) := Enclosing_Instance.Locations;
185 function Make_Msg_Loc
187 Loc : Source_Location) return Message_And_Location
190 return Message_And_Location'(Count => Loc.Count,
199 function Message (Item : Message_And_Location) return SA_Message is
202 package Field_Names is
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.
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";
227 package body Writing is
229 -- The file to which output will be written (in Close, not in Write)
231 Messages : JSON_Array;
232 -- Successive calls to Write append messages to this list
234 -----------------------
235 -- Local subprograms --
236 -----------------------
238 function To_JSON_Array
239 (Locations : Source_Locations) return JSON_Array;
240 -- Represent a Source_Locations array as a JSON_Array
242 function To_JSON_Value
243 (Location : Simple_Source_Location) return JSON_Value;
244 -- Represent a Simple_Source_Location as a JSON_Value
251 Value : constant JSON_Value := Create_Object;
254 -- only one field for now
255 Set_Field (Value, Field_Names.Messages, Messages);
256 Put_Line (File, Write (Item => Value, Compact => False));
258 Close (File => File);
265 function Is_Open return Boolean is (Is_Open (File));
271 procedure Open (File_Name : String) is
273 Create (File => File, Mode => Out_File, Name => File_Name);
281 function To_JSON_Array
282 (Locations : Source_Locations) return JSON_Array
285 return Result : JSON_Array := Empty_Array do
286 for Location of Locations loop
287 Append (Result, To_JSON_Value (Location));
296 function To_JSON_Value
297 (Location : Simple_Source_Location) return JSON_Value
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)));
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);
320 procedure Write (Message : SA_Message; Location : Source_Location) is
321 Value : constant JSON_Value := Create_Object;
324 Set_Field (Value, Field_Names.Message_Kind, Message.Kind'Img);
326 if Message.Kind in Check_Kind then
328 (Value, Field_Names.Check_Result, Message.Check_Result'Img);
332 (Value, Field_Names.Locations, To_JSON_Array (Location.Locations));
333 Append (Messages, Value);
337 package body Reading is
339 -- The file from which messages are read (in Open, not in Read)
341 Messages : JSON_Array;
342 -- The list of messages that were read in from File
344 Next_Index : Positive;
345 -- The index of the message in Messages which will be returned by the
348 Parse_Full_Path : Boolean := True;
349 -- if the full path or only the base name of the file should be parsed
365 function Done return Boolean is (Next_Index > Length (Messages));
371 function Get return Message_And_Location is
372 Value : constant JSON_Value := Get (Messages, Next_Index);
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.
379 (Location : Source_Location;
380 Message : SA_Message) return Message_And_Location;
384 (Encoded : JSON_Array;
385 Full_Path : Boolean) return Source_Location;
386 -- Decode a Source_Location from JSON_Array representation
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
397 function Get_Message (Kind : Message_Kind) return SA_Message is
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.
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));
417 (Location : Source_Location;
418 Message : SA_Message) return Message_And_Location
420 (Count => Location.Count, Message => Message, Location => Location);
427 (Encoded : JSON_Array;
428 Full_Path : Boolean) return Source_Location is
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);
438 ------------------------
439 -- To_Simple_Location --
440 ------------------------
442 function To_Simple_Location
443 (Encoded : JSON_Value;
444 Full_Path : Boolean) return Simple_Source_Location
446 function Get_Iteration_Id
447 (Kind : Iteration_Kind) return Iteration_Id;
448 -- Given the discriminant for an Iteration_Id value, return the
451 ----------------------
452 -- Get_Iteration_Id --
453 ----------------------
455 function Get_Iteration_Id (Kind : Iteration_Kind)
459 -- Initialize non-discriminant fields, if any
461 return Result : Iteration_Id (Kind => Kind) do
462 if Kind = Numbered then
466 Get (Encoded, Field_Names.Iteration_Number),
468 Get (Encoded, Field_Names.Iteration_Of_Total));
471 end Get_Iteration_Id;
475 FN : constant Unbounded_String :=
476 Get (Encoded, Field_Names.File_Name);
478 -- Start of processing for To_Simple_Location
486 To_Unbounded_String (Simple_Name (To_String (FN)))),
488 Line_Number (Integer'(Get (Encoded, Field_Names.Line))),
490 Column_Number (Integer'(Get (Encoded, Field_Names.Column))),
493 (Kind => Iteration_Kind'Val (Integer'(Get
494 (Encoded, Field_Names.Iteration_Kind)))));
495 end To_Simple_Location;
497 -- Start of processing for Get
500 Next_Index := Next_Index + 1;
505 (Message_Kind'Value (Get (Value, Field_Names.Message_Kind))),
508 (Get (Value, Field_Names.Locations), Parse_Full_Path));
515 function Is_Open return Boolean is (Is_Open (File));
521 procedure Open (File_Name : String; Full_Path : Boolean := True) is
522 File_Text : Unbounded_String := Null_Unbounded_String;
525 Parse_Full_Path := Full_Path;
526 Open (File => File, Mode => In_File, Name => File_Name);
528 -- File read here, not in Get, but that's an implementation detail
530 while not End_Of_File (File) loop
531 Append (File_Text, Get_Line (File));
534 Messages := Get (Read (File_Text), Field_Names.Messages);