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