1 ------------------------------------------------------------------------------
2 -- C O D E P E E R / S P A R K --
4 -- Copyright (C) 2015-2018, 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);