blob: 41c0db1c24d7d29ed356d30ea435f2b8dcf10383 [file] [log] [blame]
------------------------------------------------------------------------------
-- C O D E P E E R / S P A R K --
-- --
-- Copyright (C) 2015-2021, AdaCore --
-- --
-- This is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. This software is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for more details. You should have received a copy of the GNU --
-- General Public License distributed with this software; see file --
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license. --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
with Ada.Directories; use Ada.Directories;
with Ada.Strings.Unbounded.Hash;
with Ada.Text_IO; use Ada.Text_IO;
with GNATCOLL.JSON; use GNATCOLL.JSON;
package body SA_Messages is
-----------------------
-- Local subprograms --
-----------------------
function "<" (Left, Right : SA_Message) return Boolean is
(if Left.Kind /= Right.Kind then
Left.Kind < Right.Kind
else
Left.Kind in Check_Kind
and then Left.Check_Result < Right.Check_Result);
function "<" (Left, Right : Simple_Source_Location) return Boolean is
(if Left.File_Name /= Right.File_Name then
Left.File_Name < Right.File_Name
elsif Left.Line /= Right.Line then
Left.Line < Right.Line
else
Left.Column < Right.Column);
function "<" (Left, Right : Source_Locations) return Boolean is
(if Left'Length /= Right'Length then
Left'Length < Right'Length
elsif Left'Length = 0 then
False
elsif Left (Left'Last) /= Right (Right'Last) then
Left (Left'Last) < Right (Right'Last)
else
Left (Left'First .. Left'Last - 1) <
Right (Right'First .. Right'Last - 1));
function "<" (Left, Right : Source_Location) return Boolean is
(Left.Locations < Right.Locations);
function Base_Location
(Location : Source_Location) return Simple_Source_Location is
(Location.Locations (1));
function Hash (Key : SA_Message) return Hash_Type;
function Hash (Key : Source_Location) return Hash_Type;
---------
-- "<" --
---------
function "<" (Left, Right : Message_And_Location) return Boolean is
(if Left.Message = Right.Message
then Left.Location < Right.Location
else Left.Message < Right.Message);
------------
-- Column --
------------
function Column (Location : Source_Location) return Column_Number is
(Base_Location (Location).Column);
---------------
-- File_Name --
---------------
function File_Name (Location : Source_Location) return String is
(To_String (Base_Location (Location).File_Name));
function File_Name (Location : Source_Location) return Unbounded_String is
(Base_Location (Location).File_Name);
------------------------
-- Enclosing_Instance --
------------------------
function Enclosing_Instance
(Location : Source_Location) return Source_Location_Or_Null is
(Count => Location.Count - 1,
Locations => Location.Locations (2 .. Location.Count));
----------
-- Hash --
----------
function Hash (Key : Message_And_Location) return Hash_Type is
(Hash (Key.Message) + Hash (Key.Location));
function Hash (Key : SA_Message) return Hash_Type is
begin
return Result : Hash_Type :=
Hash_Type'Mod (Message_Kind'Pos (Key.Kind))
do
if Key.Kind in Check_Kind then
Result := Result +
Hash_Type'Mod (SA_Check_Result'Pos (Key.Check_Result));
end if;
end return;
end Hash;
function Hash (Key : Source_Location) return Hash_Type is
begin
return Result : Hash_Type := Hash_Type'Mod (Key.Count) do
for Loc of Key.Locations loop
Result := Result + Hash (Loc.File_Name);
Result := Result + Hash_Type'Mod (Loc.Line);
Result := Result + Hash_Type'Mod (Loc.Column);
end loop;
end return;
end Hash;
---------------
-- Iteration --
---------------
function Iteration (Location : Source_Location) return Iteration_Id is
(Base_Location (Location).Iteration);
----------
-- Line --
----------
function Line (Location : Source_Location) return Line_Number is
(Base_Location (Location).Line);
--------------
-- Location --
--------------
function Location
(Item : Message_And_Location) return Source_Location is
(Item.Location);
----------
-- Make --
----------
function Make
(File_Name : String;
Line : Line_Number;
Column : Column_Number;
Iteration : Iteration_Id;
Enclosing_Instance : Source_Location_Or_Null) return Source_Location
is
begin
return Result : Source_Location
(Count => Enclosing_Instance.Count + 1)
do
Result.Locations (1) :=
(File_Name => To_Unbounded_String (File_Name),
Line => Line,
Column => Column,
Iteration => Iteration);
Result.Locations (2 .. Result.Count) := Enclosing_Instance.Locations;
end return;
end Make;
------------------
-- Make_Msg_Loc --
------------------
function Make_Msg_Loc
(Msg : SA_Message;
Loc : Source_Location) return Message_And_Location
is
begin
return Message_And_Location'(Count => Loc.Count,
Message => Msg,
Location => Loc);
end Make_Msg_Loc;
-------------
-- Message --
-------------
function Message (Item : Message_And_Location) return SA_Message is
(Item.Message);
package Field_Names is
-- A Source_Location value is represented in JSON as a two or three
-- field value having fields Message_Kind (a string) and Locations (an
-- array); if the Message_Kind indicates a check kind, then a third
-- field is present: Check_Result (a string). The element type of the
-- Locations array is a value having at least 4 fields:
-- File_Name (a string), Line (an integer), Column (an integer),
-- and Iteration_Kind (an integer); if the Iteration_Kind field
-- has the value corresponding to the enumeration literal Numbered,
-- then two additional integer fields are present, Iteration_Number
-- and Iteration_Of_Total.
Check_Result : constant String := "Check_Result";
Column : constant String := "Column";
File_Name : constant String := "File_Name";
Iteration_Kind : constant String := "Iteration_Kind";
Iteration_Number : constant String := "Iteration_Number";
Iteration_Of_Total : constant String := "Iteration_Total";
Line : constant String := "Line";
Locations : constant String := "Locations";
Message_Kind : constant String := "Message_Kind";
Messages : constant String := "Messages";
end Field_Names;
package body Writing is
File : File_Type;
-- The file to which output will be written (in Close, not in Write)
Messages : JSON_Array;
-- Successive calls to Write append messages to this list
-----------------------
-- Local subprograms --
-----------------------
function To_JSON_Array
(Locations : Source_Locations) return JSON_Array;
-- Represent a Source_Locations array as a JSON_Array
function To_JSON_Value
(Location : Simple_Source_Location) return JSON_Value;
-- Represent a Simple_Source_Location as a JSON_Value
-----------
-- Close --
-----------
procedure Close is
Value : constant JSON_Value := Create_Object;
begin
-- only one field for now
Set_Field (Value, Field_Names.Messages, Messages);
Put_Line (File, Write (Item => Value, Compact => False));
Clear (Messages);
Close (File => File);
end Close;
-------------
-- Is_Open --
-------------
function Is_Open return Boolean is (Is_Open (File));
----------
-- Open --
----------
procedure Open (File_Name : String) is
begin
Create (File => File, Mode => Out_File, Name => File_Name);
Clear (Messages);
end Open;
-------------------
-- To_JSON_Array --
-------------------
function To_JSON_Array
(Locations : Source_Locations) return JSON_Array
is
begin
return Result : JSON_Array := Empty_Array do
for Location of Locations loop
Append (Result, To_JSON_Value (Location));
end loop;
end return;
end To_JSON_Array;
-------------------
-- To_JSON_Value --
-------------------
function To_JSON_Value
(Location : Simple_Source_Location) return JSON_Value
is
begin
return Result : constant JSON_Value := Create_Object do
Set_Field (Result, Field_Names.File_Name, Location.File_Name);
Set_Field (Result, Field_Names.Line, Integer (Location.Line));
Set_Field (Result, Field_Names.Column, Integer (Location.Column));
Set_Field (Result, Field_Names.Iteration_Kind, Integer'(
Iteration_Kind'Pos (Location.Iteration.Kind)));
if Location.Iteration.Kind = Numbered then
Set_Field (Result, Field_Names.Iteration_Number,
Location.Iteration.Number);
Set_Field (Result, Field_Names.Iteration_Of_Total,
Location.Iteration.Of_Total);
end if;
end return;
end To_JSON_Value;
-----------
-- Write --
-----------
procedure Write (Message : SA_Message; Location : Source_Location) is
Value : constant JSON_Value := Create_Object;
begin
Set_Field (Value, Field_Names.Message_Kind, Message.Kind'Img);
if Message.Kind in Check_Kind then
Set_Field
(Value, Field_Names.Check_Result, Message.Check_Result'Img);
end if;
Set_Field
(Value, Field_Names.Locations, To_JSON_Array (Location.Locations));
Append (Messages, Value);
end Write;
end Writing;
package body Reading is
File : File_Type;
-- The file from which messages are read (in Open, not in Read)
Messages : JSON_Array;
-- The list of messages that were read in from File
Next_Index : Positive;
-- The index of the message in Messages which will be returned by the
-- next call to Get.
Parse_Full_Path : Boolean := True;
-- if the full path or only the base name of the file should be parsed
-----------
-- Close --
-----------
procedure Close is
begin
Clear (Messages);
Close (File);
end Close;
----------
-- Done --
----------
function Done return Boolean is (Next_Index > Length (Messages));
---------
-- Get --
---------
function Get return Message_And_Location is
Value : constant JSON_Value := Get (Messages, Next_Index);
function Get_Message (Kind : Message_Kind) return SA_Message;
-- Return SA_Message of given kind, filling in any non-discriminant
-- by reading from Value.
function Make
(Location : Source_Location;
Message : SA_Message) return Message_And_Location;
-- Constructor
function To_Location
(Encoded : JSON_Array;
Full_Path : Boolean) return Source_Location;
-- Decode a Source_Location from JSON_Array representation
function To_Simple_Location
(Encoded : JSON_Value;
Full_Path : Boolean) return Simple_Source_Location;
-- Decode a Simple_Source_Location from JSON_Value representation
-----------------
-- Get_Message --
-----------------
function Get_Message (Kind : Message_Kind) return SA_Message is
begin
-- If we had AI12-0086, then we could use aggregates here (which
-- would be better than field-by-field assignment for the usual
-- maintainability reasons). But we don't, so we won't.
return Result : SA_Message (Kind => Kind) do
if Kind in Check_Kind then
Result.Check_Result :=
SA_Check_Result'Value
(Get (Value, Field_Names.Check_Result));
end if;
end return;
end Get_Message;
----------
-- Make --
----------
function Make
(Location : Source_Location;
Message : SA_Message) return Message_And_Location
is
(Count => Location.Count, Message => Message, Location => Location);
-----------------
-- To_Location --
-----------------
function To_Location
(Encoded : JSON_Array;
Full_Path : Boolean) return Source_Location is
begin
return Result : Source_Location (Count => Length (Encoded)) do
for I in Result.Locations'Range loop
Result.Locations (I) :=
To_Simple_Location (Get (Encoded, I), Full_Path);
end loop;
end return;
end To_Location;
------------------------
-- To_Simple_Location --
------------------------
function To_Simple_Location
(Encoded : JSON_Value;
Full_Path : Boolean) return Simple_Source_Location
is
function Get_Iteration_Id
(Kind : Iteration_Kind) return Iteration_Id;
-- Given the discriminant for an Iteration_Id value, return the
-- entire value.
----------------------
-- Get_Iteration_Id --
----------------------
function Get_Iteration_Id (Kind : Iteration_Kind)
return Iteration_Id
is
begin
-- Initialize non-discriminant fields, if any
return Result : Iteration_Id (Kind => Kind) do
if Kind = Numbered then
Result :=
(Kind => Numbered,
Number =>
Get (Encoded, Field_Names.Iteration_Number),
Of_Total =>
Get (Encoded, Field_Names.Iteration_Of_Total));
end if;
end return;
end Get_Iteration_Id;
-- Local variables
FN : constant Unbounded_String :=
Get (Encoded, Field_Names.File_Name);
-- Start of processing for To_Simple_Location
begin
return
(File_Name =>
(if Full_Path then
FN
else
To_Unbounded_String (Simple_Name (To_String (FN)))),
Line =>
Line_Number (Integer'(Get (Encoded, Field_Names.Line))),
Column =>
Column_Number (Integer'(Get (Encoded, Field_Names.Column))),
Iteration =>
Get_Iteration_Id
(Kind => Iteration_Kind'Val (Integer'(Get
(Encoded, Field_Names.Iteration_Kind)))));
end To_Simple_Location;
-- Start of processing for Get
begin
Next_Index := Next_Index + 1;
return Make
(Message =>
Get_Message
(Message_Kind'Value (Get (Value, Field_Names.Message_Kind))),
Location =>
To_Location
(Get (Value, Field_Names.Locations), Parse_Full_Path));
end Get;
-------------
-- Is_Open --
-------------
function Is_Open return Boolean is (Is_Open (File));
----------
-- Open --
----------
procedure Open (File_Name : String; Full_Path : Boolean := True) is
File_Text : Unbounded_String := Null_Unbounded_String;
begin
Parse_Full_Path := Full_Path;
Open (File => File, Mode => In_File, Name => File_Name);
-- File read here, not in Get, but that's an implementation detail
while not End_Of_File (File) loop
Append (File_Text, Get_Line (File));
end loop;
Messages := Get (Read (File_Text), Field_Names.Messages);
Next_Index := 1;
end Open;
end Reading;
end SA_Messages;