1------------------------------------------------------------------------------ 2-- C O D E P E E R / S P A R K -- 3-- -- 4-- Copyright (C) 2015-2019, AdaCore -- 5-- -- 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 -- 15-- of the license. -- 16-- -- 17------------------------------------------------------------------------------ 18 19pragma Ada_2012; 20 21with Ada.Directories; use Ada.Directories; 22with Ada.Strings.Unbounded.Hash; 23 24with Ada.Text_IO; use Ada.Text_IO; 25with GNATCOLL.JSON; use GNATCOLL.JSON; 26 27package body SA_Messages is 28 29 ----------------------- 30 -- Local subprograms -- 31 ----------------------- 32 33 function "<" (Left, Right : SA_Message) return Boolean is 34 (if Left.Kind /= Right.Kind then 35 Left.Kind < Right.Kind 36 else 37 Left.Kind in Check_Kind 38 and then Left.Check_Result < Right.Check_Result); 39 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 45 else 46 Left.Column < Right.Column); 47 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 52 False 53 elsif Left (Left'Last) /= Right (Right'Last) then 54 Left (Left'Last) < Right (Right'Last) 55 else 56 Left (Left'First .. Left'Last - 1) < 57 Right (Right'First .. Right'Last - 1)); 58 59 function "<" (Left, Right : Source_Location) return Boolean is 60 (Left.Locations < Right.Locations); 61 62 function Base_Location 63 (Location : Source_Location) return Simple_Source_Location is 64 (Location.Locations (1)); 65 66 function Hash (Key : SA_Message) return Hash_Type; 67 function Hash (Key : Source_Location) return Hash_Type; 68 69 --------- 70 -- "<" -- 71 --------- 72 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); 77 78 ------------ 79 -- Column -- 80 ------------ 81 82 function Column (Location : Source_Location) return Column_Number is 83 (Base_Location (Location).Column); 84 85 --------------- 86 -- File_Name -- 87 --------------- 88 89 function File_Name (Location : Source_Location) return String is 90 (To_String (Base_Location (Location).File_Name)); 91 92 function File_Name (Location : Source_Location) return Unbounded_String is 93 (Base_Location (Location).File_Name); 94 95 ------------------------ 96 -- Enclosing_Instance -- 97 ------------------------ 98 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)); 103 104 ---------- 105 -- Hash -- 106 ---------- 107 108 function Hash (Key : Message_And_Location) return Hash_Type is 109 (Hash (Key.Message) + Hash (Key.Location)); 110 111 function Hash (Key : SA_Message) return Hash_Type is 112 begin 113 return Result : Hash_Type := 114 Hash_Type'Mod (Message_Kind'Pos (Key.Kind)) 115 do 116 if Key.Kind in Check_Kind then 117 Result := Result + 118 Hash_Type'Mod (SA_Check_Result'Pos (Key.Check_Result)); 119 end if; 120 end return; 121 end Hash; 122 123 function Hash (Key : Source_Location) return Hash_Type is 124 begin 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); 130 end loop; 131 end return; 132 end Hash; 133 134 --------------- 135 -- Iteration -- 136 --------------- 137 138 function Iteration (Location : Source_Location) return Iteration_Id is 139 (Base_Location (Location).Iteration); 140 141 ---------- 142 -- Line -- 143 ---------- 144 145 function Line (Location : Source_Location) return Line_Number is 146 (Base_Location (Location).Line); 147 148 -------------- 149 -- Location -- 150 -------------- 151 152 function Location 153 (Item : Message_And_Location) return Source_Location is 154 (Item.Location); 155 156 ---------- 157 -- Make -- 158 ---------- 159 160 function Make 161 (File_Name : String; 162 Line : Line_Number; 163 Column : Column_Number; 164 Iteration : Iteration_Id; 165 Enclosing_Instance : Source_Location_Or_Null) return Source_Location 166 is 167 begin 168 return Result : Source_Location 169 (Count => Enclosing_Instance.Count + 1) 170 do 171 Result.Locations (1) := 172 (File_Name => To_Unbounded_String (File_Name), 173 Line => Line, 174 Column => Column, 175 Iteration => Iteration); 176 177 Result.Locations (2 .. Result.Count) := Enclosing_Instance.Locations; 178 end return; 179 end Make; 180 181 ------------------ 182 -- Make_Msg_Loc -- 183 ------------------ 184 185 function Make_Msg_Loc 186 (Msg : SA_Message; 187 Loc : Source_Location) return Message_And_Location 188 is 189 begin 190 return Message_And_Location'(Count => Loc.Count, 191 Message => Msg, 192 Location => Loc); 193 end Make_Msg_Loc; 194 195 ------------- 196 -- Message -- 197 ------------- 198 199 function Message (Item : Message_And_Location) return SA_Message is 200 (Item.Message); 201 202 package Field_Names is 203 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. 214 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"; 225 end Field_Names; 226 227 package body Writing is 228 File : File_Type; 229 -- The file to which output will be written (in Close, not in Write) 230 231 Messages : JSON_Array; 232 -- Successive calls to Write append messages to this list 233 234 ----------------------- 235 -- Local subprograms -- 236 ----------------------- 237 238 function To_JSON_Array 239 (Locations : Source_Locations) return JSON_Array; 240 -- Represent a Source_Locations array as a JSON_Array 241 242 function To_JSON_Value 243 (Location : Simple_Source_Location) return JSON_Value; 244 -- Represent a Simple_Source_Location as a JSON_Value 245 246 ----------- 247 -- Close -- 248 ----------- 249 250 procedure Close is 251 Value : constant JSON_Value := Create_Object; 252 253 begin 254 -- only one field for now 255 Set_Field (Value, Field_Names.Messages, Messages); 256 Put_Line (File, Write (Item => Value, Compact => False)); 257 Clear (Messages); 258 Close (File => File); 259 end Close; 260 261 ------------- 262 -- Is_Open -- 263 ------------- 264 265 function Is_Open return Boolean is (Is_Open (File)); 266 267 ---------- 268 -- Open -- 269 ---------- 270 271 procedure Open (File_Name : String) is 272 begin 273 Create (File => File, Mode => Out_File, Name => File_Name); 274 Clear (Messages); 275 end Open; 276 277 ------------------- 278 -- To_JSON_Array -- 279 ------------------- 280 281 function To_JSON_Array 282 (Locations : Source_Locations) return JSON_Array 283 is 284 begin 285 return Result : JSON_Array := Empty_Array do 286 for Location of Locations loop 287 Append (Result, To_JSON_Value (Location)); 288 end loop; 289 end return; 290 end To_JSON_Array; 291 292 ------------------- 293 -- To_JSON_Value -- 294 ------------------- 295 296 function To_JSON_Value 297 (Location : Simple_Source_Location) return JSON_Value 298 is 299 begin 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))); 306 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); 312 end if; 313 end return; 314 end To_JSON_Value; 315 316 ----------- 317 -- Write -- 318 ----------- 319 320 procedure Write (Message : SA_Message; Location : Source_Location) is 321 Value : constant JSON_Value := Create_Object; 322 323 begin 324 Set_Field (Value, Field_Names.Message_Kind, Message.Kind'Img); 325 326 if Message.Kind in Check_Kind then 327 Set_Field 328 (Value, Field_Names.Check_Result, Message.Check_Result'Img); 329 end if; 330 331 Set_Field 332 (Value, Field_Names.Locations, To_JSON_Array (Location.Locations)); 333 Append (Messages, Value); 334 end Write; 335 end Writing; 336 337 package body Reading is 338 File : File_Type; 339 -- The file from which messages are read (in Open, not in Read) 340 341 Messages : JSON_Array; 342 -- The list of messages that were read in from File 343 344 Next_Index : Positive; 345 -- The index of the message in Messages which will be returned by the 346 -- next call to Get. 347 348 Parse_Full_Path : Boolean := True; 349 -- if the full path or only the base name of the file should be parsed 350 351 ----------- 352 -- Close -- 353 ----------- 354 355 procedure Close is 356 begin 357 Clear (Messages); 358 Close (File); 359 end Close; 360 361 ---------- 362 -- Done -- 363 ---------- 364 365 function Done return Boolean is (Next_Index > Length (Messages)); 366 367 --------- 368 -- Get -- 369 --------- 370 371 function Get return Message_And_Location is 372 Value : constant JSON_Value := Get (Messages, Next_Index); 373 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. 377 378 function Make 379 (Location : Source_Location; 380 Message : SA_Message) return Message_And_Location; 381 -- Constructor 382 383 function To_Location 384 (Encoded : JSON_Array; 385 Full_Path : Boolean) return Source_Location; 386 -- Decode a Source_Location from JSON_Array representation 387 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 392 393 ----------------- 394 -- Get_Message -- 395 ----------------- 396 397 function Get_Message (Kind : Message_Kind) return SA_Message is 398 begin 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. 402 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)); 408 end if; 409 end return; 410 end Get_Message; 411 412 ---------- 413 -- Make -- 414 ---------- 415 416 function Make 417 (Location : Source_Location; 418 Message : SA_Message) return Message_And_Location 419 is 420 (Count => Location.Count, Message => Message, Location => Location); 421 422 ----------------- 423 -- To_Location -- 424 ----------------- 425 426 function To_Location 427 (Encoded : JSON_Array; 428 Full_Path : Boolean) return Source_Location is 429 begin 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); 434 end loop; 435 end return; 436 end To_Location; 437 438 ------------------------ 439 -- To_Simple_Location -- 440 ------------------------ 441 442 function To_Simple_Location 443 (Encoded : JSON_Value; 444 Full_Path : Boolean) return Simple_Source_Location 445 is 446 function Get_Iteration_Id 447 (Kind : Iteration_Kind) return Iteration_Id; 448 -- Given the discriminant for an Iteration_Id value, return the 449 -- entire value. 450 451 ---------------------- 452 -- Get_Iteration_Id -- 453 ---------------------- 454 455 function Get_Iteration_Id (Kind : Iteration_Kind) 456 return Iteration_Id 457 is 458 begin 459 -- Initialize non-discriminant fields, if any 460 461 return Result : Iteration_Id (Kind => Kind) do 462 if Kind = Numbered then 463 Result := 464 (Kind => Numbered, 465 Number => 466 Get (Encoded, Field_Names.Iteration_Number), 467 Of_Total => 468 Get (Encoded, Field_Names.Iteration_Of_Total)); 469 end if; 470 end return; 471 end Get_Iteration_Id; 472 473 -- Local variables 474 475 FN : constant Unbounded_String := 476 Get (Encoded, Field_Names.File_Name); 477 478 -- Start of processing for To_Simple_Location 479 480 begin 481 return 482 (File_Name => 483 (if Full_Path then 484 FN 485 else 486 To_Unbounded_String (Simple_Name (To_String (FN)))), 487 Line => 488 Line_Number (Integer'(Get (Encoded, Field_Names.Line))), 489 Column => 490 Column_Number (Integer'(Get (Encoded, Field_Names.Column))), 491 Iteration => 492 Get_Iteration_Id 493 (Kind => Iteration_Kind'Val (Integer'(Get 494 (Encoded, Field_Names.Iteration_Kind))))); 495 end To_Simple_Location; 496 497 -- Start of processing for Get 498 499 begin 500 Next_Index := Next_Index + 1; 501 502 return Make 503 (Message => 504 Get_Message 505 (Message_Kind'Value (Get (Value, Field_Names.Message_Kind))), 506 Location => 507 To_Location 508 (Get (Value, Field_Names.Locations), Parse_Full_Path)); 509 end Get; 510 511 ------------- 512 -- Is_Open -- 513 ------------- 514 515 function Is_Open return Boolean is (Is_Open (File)); 516 517 ---------- 518 -- Open -- 519 ---------- 520 521 procedure Open (File_Name : String; Full_Path : Boolean := True) is 522 File_Text : Unbounded_String := Null_Unbounded_String; 523 524 begin 525 Parse_Full_Path := Full_Path; 526 Open (File => File, Mode => In_File, Name => File_Name); 527 528 -- File read here, not in Get, but that's an implementation detail 529 530 while not End_Of_File (File) loop 531 Append (File_Text, Get_Line (File)); 532 end loop; 533 534 Messages := Get (Read (File_Text), Field_Names.Messages); 535 Next_Index := 1; 536 end Open; 537 end Reading; 538 539end SA_Messages; 540