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