path: root/gcc/ada/erroutc-sarif_emitter.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                 E R R O U T C . S A R I F _ E M I T T E R                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2025, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT 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.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- 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 GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with JSON_Utils; use JSON_Utils;
with GNAT.Lists; use GNAT.Lists;
with Gnatvsn;    use Gnatvsn;
with Lib;        use Lib;
with Namet;      use Namet;
with Output;     use Output;
with Sinput;     use Sinput;
with System.OS_Lib;

package body Erroutc.SARIF_Emitter is

   --  SARIF attribute names

   N_ARTIFACT_CHANGES      : constant String := "artifactChanges";
   N_ARTIFACT_LOCATION     : constant String := "artifactLocation";
   N_COMMAND_LINE          : constant String := "commandLine";
   N_DELETED_REGION        : constant String := "deletedRegion";
   N_DESCRIPTION           : constant String := "description";
   N_DRIVER                : constant String := "driver";
   N_END_COLUMN            : constant String := "endColumn";
   N_END_LINE              : constant String := "endLine";
   N_EXECUTION_SUCCESSFUL  : constant String := "executionSuccessful";
   N_FIXES                 : constant String := "fixes";
   N_ID                    : constant String := "id";
   N_INSERTED_CONTENT      : constant String := "insertedContent";
   N_INVOCATIONS           : constant String := "invocations";
   N_LOCATIONS             : constant String := "locations";
   N_LEVEL                 : constant String := "level";
   N_MESSAGE               : constant String := "message";
   N_NAME                  : constant String := "name";
   N_ORIGINAL_URI_BASE_IDS : constant String := "originalUriBaseIds";
   N_PHYSICAL_LOCATION     : constant String := "physicalLocation";
   N_REGION                : constant String := "region";
   N_RELATED_LOCATIONS     : constant String := "relatedLocations";
   N_REPLACEMENTS          : constant String := "replacements";
   N_RESULTS               : constant String := "results";
   N_RULES                 : constant String := "rules";
   N_RULE_ID               : constant String := "ruleId";
   N_RUNS                  : constant String := "runs";
   N_SCHEMA                : constant String := "$schema";
   N_START_COLUMN          : constant String := "startColumn";
   N_START_LINE            : constant String := "startLine";
   N_TEXT                  : constant String := "text";
   N_TOOL                  : constant String := "tool";
   N_URI                   : constant String := "uri";
   N_URI_BASE_ID           : constant String := "uriBaseId";
   N_VERSION               : constant String := "version";

   --  We are currently using SARIF 2.1.0

   SARIF_Version : constant String := "2.1.0";
   pragma Style_Checks ("M100");
   SARIF_Schema : constant String :=
     "https://docs.oasis-open.org/sarif/sarif/v2.1.0/errata01/os/schemas/sarif-schema-2.1.0.json";
   pragma Style_Checks ("M79");

   URI_Base_Id_Name : constant String := "PWD";
   --  We use the pwd as the originalUriBaseIds when providing absolute paths
   --  in locations.

   Current_Dir : constant String := Get_Current_Dir;
   --  Cached value of the current directory that is used in the URI_Base_Id
   --  and it is also the path that all other Uri attributes will be created
   --  relative to.

   procedure Destroy (Elem : in out Error_Msg_Object) is null;
   pragma Inline (Destroy);
   package Error_Msg_Lists is new Doubly_Linked_Lists
     (Element_Type    => Error_Msg_Object,
      "="             => "=",
      Destroy_Element => Destroy,
      Check_Tampering => False);

   subtype Error_Msg_List is Error_Msg_Lists.Doubly_Linked_List;

   procedure Destroy (Elem : in out Edit_Type);

   procedure Destroy (Elem : in out Edit_Type) is
   begin
      --  Diagnostic elements will be freed when all the diagnostics have been
      --  emitted.
      null;
   end Destroy;

   pragma Inline (Destroy);

   package Edit_Lists is new Doubly_Linked_Lists
     (Element_Type    => Edit_Type,
      "="             => "=",
      Destroy_Element => Destroy,
      Check_Tampering => False);

   subtype Edit_List is Edit_Lists.Doubly_Linked_List;

   type Artifact_Change is record
      File_Index : Source_File_Index;
      --  Index for the source file

      Replacements : Edit_List;
      --  Regions of texts to be edited
   end record;

   procedure Destroy (Elem : in out Artifact_Change);
   pragma Inline (Destroy);

   function Equals (L, R : Artifact_Change) return Boolean is
     (L.File_Index = R.File_Index);

   package Artifact_Change_Lists is new Doubly_Linked_Lists
     (Element_Type    => Artifact_Change,
      "="             => Equals,
      Destroy_Element => Destroy,
      Check_Tampering => False);

   subtype Artifact_Change_List is Artifact_Change_Lists.Doubly_Linked_List;

   function Get_Artifact_Changes (Fix : Fix_Type) return Artifact_Change_List;
   --  Group edits of a Fix into Artifact_Changes that organize the edits by
   --  file name.

   function Get_Unique_Rules return Error_Msg_List;
   --  Get a list of diagnostics that have unique Diagnostic Id-s.

   procedure Print_Replacement (Replacement : Edit_Type);
   --  Print a replacement node
   --
   --  {
   --    deletedRegion: {<Region>},
   --    insertedContent: {<Message>}
   --  }

   procedure Print_Fix (Fix : Fix_Type);
   --  Print the fix node
   --
   --  {
   --    description: {<Message>},
   --    artifactChanges: [<ArtifactChange>]
   --  }

   procedure Print_Fixes (E_Msg : Error_Msg_Object);
   --  Print the fixes node
   --
   --  "fixes": [
   --    <Fix>,
   --    ...
   --  ]

   procedure Print_Invocations;
   --  Print an invocations node that consists of
   --  * a single invocation node that consists of:
   --    * commandLine
   --    * executionSuccessful
   --
   --  "invocations": [
   --    {
   --      "commandLine": <command line arguments provided to the GNAT FE>,
   --      "executionSuccessful": ["true"|"false"],
   --    }
   --  ]

   procedure Print_Artifact_Change (A : Artifact_Change);
   --  Print an ArtifactChange node
   --
   --  {
   --    artifactLocation: {<ArtifactLocation>},
   --    replacements: [<Replacements>]
   --  }

   procedure Print_Artifact_Location (Sfile : Source_File_Index);
   --  Print an artifactLocation node
   --
   --   "artifactLocation": {
   --     "uri": <File_Name>,
   --     "uriBaseId": "PWD"
   --   }

   procedure Print_Location (Loc : Labeled_Span_Type; Msg : String_Ptr);
   --  Print a location node that consists of
   --  * an optional message node
   --  * a physicalLocation node
   --    * ArtifactLocation node that consists of the file name
   --    * Region node that consists of the start and end positions of the span
   --
   --  {
   --    "message": {
   --      "text": <Msg>
   --    },
   --    "physicalLocation": {
   --      "artifactLocation": {
   --        "uri": <File_Name (Loc)>
   --      },
   --      "region": {
   --        "startLine": <Line(Loc.Fst)>,
   --        "startColumn": <Col(Loc.Fst)>,
   --        "endLine": <Line(Loc.Lst)>,
   --        "endColumn": Col(Loc.Lst)>
   --      }
   --    }
   --  }

   procedure Print_Locations (E_Msg : Error_Msg_Object);
   --  Print a locations node that consists of multiple location nodes. However
   --  typically just one location for the primary span of the diagnostic.
   --
   --   "locations": [
   --      <Location (Primary_Span (Diag))>
   --   ],

   procedure Print_Message (Text : String; Name : String := N_MESSAGE);
   --  Print a SARIF message node.
   --
   --  There are many message type nodes in the SARIF report however they can
   --  have a different node <Name>.
   --
   --  <Name>: {
   --    "text": <text>
   --  },

   procedure Print_Original_Uri_Base_Ids;
   --  Print the originalUriBaseIds that holds the PWD value
   --
   --  "originalUriBaseIds": {
   --    "PWD": {
   --      "uri": "<current_working_directory>"
   --    }
   --  },

   procedure Print_Related_Locations (E_Msg : Error_Msg_Object);
   --  Print a relatedLocations node that consists of multiple location nodes.
   --  Related locations are the non-primary spans of the diagnostic and the
   --  primary locations of sub-diagnostics.
   --
   --   "relatedLocations": [
   --      <Location (Diag.Loc)>
   --   ],

   procedure Print_Region
     (Start_Line : Int;
      Start_Col  : Int;
      End_Line   : Int;
      End_Col    : Int;
      Name       : String := N_REGION);
   --  Print a region node.
   --
   --  More specifically a text region node that specifies the textual
   --  location of the region. Note that in SARIF there are also binary
   --  regions.
   --
   --   "<Name>": {
   --     "startLine": Start_Line,
   --     "startColumn": Start_Col,
   --     "endLine": End_Line,
   --     "endColumn": End_Col + 1
   --   }
   --
   --  Note that there are many types of nodes that can have a region type,
   --  but have a different node name.
   --
   --  The end column is defined differently in the SARIF report than it is
   --  for the spans within GNAT. Internally we consider the end column of a
   --  span to be the last character of the span.
   --
   --  However in SARIF the end column is defined as:
   --  "The column number of the character following the end of the region"
   --
   --  This method assumes that the End_Col passed to this procedure is using
   --  the GNAT span definition and we amend the endColumn value so that it
   --  matches the SARIF definition.

   procedure Print_Result (E_Msg : Error_Msg_Object);
   --   {
   --     "ruleId": <Diag.Id>,
   --     "level": <Diag.Kind>,
   --     "message": {
   --       "text": <Diag.Message>
   --     },
   --     "locations": [<Primary_Location>],
   --     "relatedLocations": [<Secondary_Locations>]
   --  },

   procedure Print_Results;
   --  Print a results node that consists of multiple result nodes for each
   --  diagnostic instance.
   --
   --   "results": [
   --     <Result (Diag)>
   --   ]

   procedure Print_Rule (E : Error_Msg_Object);
   --  Print a rule node that consists of the following attributes:
   --  * ruleId
   --  * name
   --
   --  {
   --    "id": <Diag.Id>,
   --    "name": <Human_Id(Diag)>
   --  },

   procedure Print_Rules;
   --  Print a rules node that consists of multiple rule nodes.
   --  Rules are considered to be a set of unique diagnostics with the unique
   --  id-s.
   --
   --   "rules": [
   --     <Rule (Diag)>
   --   ]

   procedure Print_Runs;
   --  Print a runs node that can consist of multiple run nodes.
   --  However for our report it consists of a single run that consists of
   --  * a tool node
   --  * a results node
   --
   --   {
   --     "tool": { <Tool (Diags)> },
   --     "results": [<Results (Diags)>]
   --   }

   procedure Print_Tool;
   --  Print a tool node that consists of
   --  * a driver node that consists of:
   --    * name
   --    * version
   --    * rules
   --
   --  "tool": {
   --    "driver": {
   --      "name": "GNAT",
   --      "version": <GNAT_Version>,
   --      "rules": [<Rules (Diags)>]
   --    }
   --  }

   -------------
   -- Destroy --
   -------------

   procedure Destroy (Elem : in out Artifact_Change) is
   begin
      Edit_Lists.Destroy (Elem.Replacements);
   end Destroy;

   --------------------------
   -- Get_Artifact_Changes --
   --------------------------

   function Get_Artifact_Changes (Fix : Fix_Type) return Artifact_Change_List
   is
      procedure Insert (Changes : Artifact_Change_List; E : Edit_Type);

      ------------
      -- Insert --
      ------------

      procedure Insert (Changes : Artifact_Change_List; E : Edit_Type) is
         A : Artifact_Change;

         It : Artifact_Change_Lists.Iterator :=
           Artifact_Change_Lists.Iterate (Changes);
      begin
         while Artifact_Change_Lists.Has_Next (It) loop
            Artifact_Change_Lists.Next (It, A);

            if A.File_Index = Get_Source_File_Index (E.Span.Ptr) then
               Edit_Lists.Append (A.Replacements, E);
               return;
            end if;
         end loop;

         declare
            Replacements : constant Edit_List := Edit_Lists.Create;
         begin
            Edit_Lists.Append (Replacements, E);
            Artifact_Change_Lists.Append
              (Changes,
              (File_Index    => Get_Source_File_Index (E.Span.Ptr),
                Replacements => Replacements));
         end;
      end Insert;

      Changes : constant Artifact_Change_List := Artifact_Change_Lists.Create;

      E : Edit_Type;

      It : Edit_Id;

      --  Start of processing for Get_Artifact_Changes

   begin
      It := Fix.Edits;

      while It /= No_Edit loop
         E := Edits.Table (It);

         Insert (Changes, E);

         It := E.Next;
      end loop;

      return Changes;
   end Get_Artifact_Changes;

   ----------------------
   -- Get_Unique_Rules --
   ----------------------

   function Get_Unique_Rules return Error_Msg_List is
      use Error_Msg_Lists;

      procedure Insert (Rules : Error_Msg_List; E : Error_Msg_Object);

      ------------
      -- Insert --
      ------------

      procedure Insert (Rules : Error_Msg_List; E : Error_Msg_Object) is
         It : Iterator := Iterate (Rules);
         R  : Error_Msg_Object;
      begin
         while Has_Next (It) loop
            Next (It, R);

            if R.Id = E.Id then
               return;
            elsif R.Id > E.Id then
               Insert_Before (Rules, R, E);
               return;
            end if;
         end loop;

         Append (Rules, E);
      end Insert;

      Unique_Rules : constant Error_Msg_List := Create;

      E : Error_Msg_Id;

      --  Start of processing for Get_Unique_Rules

   begin
      E := First_Error_Msg;
      while E /= No_Error_Msg loop
         Insert (Unique_Rules, Errors.Table (E));

         Next_Error_Msg (E);
      end loop;

      return Unique_Rules;
   end Get_Unique_Rules;

   ---------------------------
   -- Print_Artifact_Change --
   ---------------------------

   procedure Print_Artifact_Change (A : Artifact_Change) is
      use Edit_Lists;
      E    : Edit_Type;
      E_It : Iterator;

      First : Boolean := True;
   begin
      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      --  Print artifactLocation

      Print_Artifact_Location (A.File_Index);

      Write_Char (',');
      NL_And_Indent;

      Write_Str ("""" & N_REPLACEMENTS & """" & ": " & "[");
      Begin_Block;
      NL_And_Indent;

      E_It := Iterate (A.Replacements);

      while Has_Next (E_It) loop
         Next (E_It, E);

         if First then
            First := False;
         else
            Write_Char (',');
         end if;

         NL_And_Indent;
         Print_Replacement (E);
      end loop;

      --  End replacements

      End_Block;
      NL_And_Indent;
      Write_Char (']');

      --  End artifactChange

      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Artifact_Change;

   -----------------------------
   -- Print_Artifact_Location --
   -----------------------------

   procedure Print_Artifact_Location (Sfile : Source_File_Index) is
      Full_Name : constant String := Get_Name_String (Full_Ref_Name (Sfile));
   begin
      Write_Str ("""" & N_ARTIFACT_LOCATION & """" & ": " & "{");
      Begin_Block;
      NL_And_Indent;

      if System.OS_Lib.Is_Absolute_Path (Full_Name) then
         declare
            Abs_Name : constant String :=
              System.OS_Lib.Normalize_Pathname
                (Name => Full_Name, Resolve_Links => False);
         begin
            --  We cannot create relative paths between different drives on
            --  Windows. If the path is on a different drive than the PWD print
            --  the absolute path in the URI and omit the baseUriId attribute.

            if Osint.On_Windows
              and then Abs_Name (Abs_Name'First) =
                Current_Dir (Current_Dir'First)
            then
               Write_String_Attribute (N_URI, To_File_Uri (Abs_Name));
            else
               Write_String_Attribute
                 (N_URI, To_File_Uri (Relative_Path (Abs_Name, Current_Dir)));

               Write_Char (',');
               NL_And_Indent;

               Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name);
            end if;
         end;
      else
         --  If the path was not absolute it was given relative to the
         --  uriBaseId.

         Write_String_Attribute (N_URI, To_File_Uri (Full_Name));

         Write_Char (',');
         NL_And_Indent;

         Write_String_Attribute (N_URI_BASE_ID, URI_Base_Id_Name);
      end if;

      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Artifact_Location;

   -----------------------
   -- Print_Replacement --
   -----------------------

   procedure Print_Replacement (Replacement : Edit_Type) is
      --  Span start positions
      Fst      : constant Source_Ptr := Replacement.Span.First;
      Line_Fst : constant Int        := Int (Get_Physical_Line_Number (Fst));
      Col_Fst  : constant Int        := Int (Get_Column_Number (Fst));

      --  Span end positions
      Lst      : constant Source_Ptr := Replacement.Span.Last;
      Line_Lst : constant Int        := Int (Get_Physical_Line_Number (Lst));
      Col_Lst  : constant Int        := Int (Get_Column_Number (Lst));
   begin
      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      --  Print deletedRegion

      Print_Region
        (Start_Line => Line_Fst,
         Start_Col  => Col_Fst,
         End_Line   => Line_Lst,
         End_Col    => Col_Lst,
         Name       => N_DELETED_REGION);

      if Replacement.Text /= null then
         Write_Char (',');
         NL_And_Indent;

         Print_Message (Replacement.Text.all, N_INSERTED_CONTENT);
      end if;

      --  End replacement

      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Replacement;

   ---------------
   -- Print_Fix --
   ---------------

   procedure Print_Fix (Fix : Fix_Type) is
      First : Boolean := True;
   begin
      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      --  Print the message if the location has one

      if Fix.Description /= null then
         Print_Message (Fix.Description.all, N_DESCRIPTION);

         Write_Char (',');
         NL_And_Indent;
      end if;

      declare
         use Artifact_Change_Lists;
         Changes : Artifact_Change_List := Get_Artifact_Changes (Fix);
         A       : Artifact_Change;
         A_It    : Iterator             := Iterate (Changes);
      begin
         Write_Str ("""" & N_ARTIFACT_CHANGES & """" & ": " & "[");
         Begin_Block;

         while Has_Next (A_It) loop
            Next (A_It, A);

            if First then
               First := False;
            else
               Write_Char (',');
            end if;

            NL_And_Indent;

            Print_Artifact_Change (A);
         end loop;

         End_Block;
         NL_And_Indent;
         Write_Char (']');

         Destroy (Changes);
      end;

      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Fix;

   -----------------
   -- Print_Fixes --
   -----------------

   procedure Print_Fixes (E_Msg : Error_Msg_Object) is
      F    : Fix_Type;
      F_It : Fix_Id;

      First : Boolean := True;
   begin
      Write_Str ("""" & N_FIXES & """" & ": " & "[");
      Begin_Block;

      F_It := E_Msg.Fixes;
      while F_It /= No_Fix loop
         F := Fixes.Table (F_It);

         if First then
            First := False;
         else
            Write_Char (',');
         end if;

         NL_And_Indent;
         Print_Fix (F);

         F_It := F.Next;
      end loop;

      End_Block;
      NL_And_Indent;
      Write_Char (']');
   end Print_Fixes;

   -----------------------
   -- Print_Invocations --
   -----------------------

   procedure Print_Invocations is

      function Compose_Command_Line return String;
      --  Composes the original command line from the parsed main file name and
      --  relevant compilation switches

      function Compose_Command_Line return String is
         Buffer : Bounded_String;
      begin
         Find_Program_Name;
         Append (Buffer, Name_Buffer (1 .. Name_Len));
         Append (Buffer, ' ');
         Append (Buffer, Get_First_Main_File_Name);
         for I in 1 .. Compilation_Switches_Last loop
            declare
               Switch : constant String := Get_Compilation_Switch (I).all;
            begin
               if Buffer.Length + Switch'Length + 1 <= Buffer.Max_Length then
                  Append (Buffer, ' ' & Switch);
               end if;
            end;
         end loop;

         return +Buffer;
      end Compose_Command_Line;

   begin
      Write_Str ("""" & N_INVOCATIONS & """" & ": " & "[");
      Begin_Block;
      NL_And_Indent;

      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      --  Print commandLine

      Write_String_Attribute (N_COMMAND_LINE, Compose_Command_Line);
      Write_Char (',');
      NL_And_Indent;

      --  Print executionSuccessful

      Write_Boolean_Attribute (N_EXECUTION_SUCCESSFUL, Exit_Code = E_Success);

      End_Block;
      NL_And_Indent;
      Write_Char ('}');

      End_Block;
      NL_And_Indent;
      Write_Char (']');
   end Print_Invocations;

   ------------------
   -- Print_Region --
   ------------------

   procedure Print_Region
     (Start_Line : Int;
      Start_Col  : Int;
      End_Line   : Int;
       End_Col   : Int;
      Name       : String := N_REGION)
   is

   begin
      Write_Str ("""" & Name & """" & ": " & "{");
      Begin_Block;
      NL_And_Indent;

      Write_Int_Attribute (N_START_LINE, Start_Line);
      Write_Char (',');
      NL_And_Indent;

      Write_Int_Attribute (N_START_COLUMN, Start_Col);
      Write_Char (',');
      NL_And_Indent;

      Write_Int_Attribute (N_END_LINE, End_Line);
      Write_Char (',');
      NL_And_Indent;

      --  Convert the end of the span to the definition of the endColumn
      --  for a SARIF region.

      Write_Int_Attribute (N_END_COLUMN, End_Col + 1);

      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Region;

   --------------------
   -- Print_Location --
   --------------------

   procedure Print_Location (Loc : Labeled_Span_Type; Msg : String_Ptr) is

      --  Span start positions
      Fst      : constant Source_Ptr := Loc.Span.First;
      Line_Fst : constant Int        := Int (Get_Physical_Line_Number (Fst));
      Col_Fst  : constant Int        := Int (Get_Column_Number (Fst));

      --  Span end positions
      Lst      : constant Source_Ptr := Loc.Span.Last;
      Line_Lst : constant Int        := Int (Get_Physical_Line_Number (Lst));
      Col_Lst  : constant Int        := Int (Get_Column_Number (Lst));

   begin
      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      --  Print the message if the location has one

      if Msg /= null then
         Print_Message (Msg.all);

         Write_Char (',');
         NL_And_Indent;
      end if;

      Write_Str ("""" & N_PHYSICAL_LOCATION & """" & ": " & "{");
      Begin_Block;
      NL_And_Indent;

      --  Print artifactLocation

      Print_Artifact_Location (Get_Source_File_Index (Loc.Span.Ptr));

      Write_Char (',');
      NL_And_Indent;

      --  Print region

      Print_Region
        (Start_Line => Line_Fst,
         Start_Col  => Col_Fst,
         End_Line   => Line_Lst,
         End_Col    => Col_Lst);

      End_Block;
      NL_And_Indent;
      Write_Char ('}');

      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Location;

   ---------------------
   -- Print_Locations --
   ---------------------

   procedure Print_Locations (E_Msg : Error_Msg_Object) is
      Loc : Labeled_Span_Type;
      It  : Labeled_Span_Id;

      First : Boolean := True;
   begin
      Write_Str ("""" & N_LOCATIONS & """" & ": " & "[");
      Begin_Block;

      It := E_Msg.Locations;
      while It /= No_Labeled_Span loop
         Loc := Locations.Table (It);

         --  Only the primary span is considered as the main location other
         --  spans are considered related locations

         if Loc.Is_Primary then
            if First then
               First := False;
            else
               Write_Char (',');
            end if;

            NL_And_Indent;
            Print_Location (Loc, Loc.Label);
         end if;

         It := Loc.Next;
      end loop;

      End_Block;
      NL_And_Indent;
      Write_Char (']');
   end Print_Locations;

   -------------------
   -- Print_Message --
   -------------------

   procedure Print_Message (Text : String; Name : String := N_MESSAGE) is

   begin
      Write_Str ("""" & Name & """" & ": " & "{");
      Begin_Block;
      NL_And_Indent;
      Write_String_Attribute (N_TEXT, Text);
      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Message;

   ---------------------------------
   -- Print_Original_Uri_Base_Ids --
   ---------------------------------

   procedure Print_Original_Uri_Base_Ids is
   begin
      Write_Str ("""" & N_ORIGINAL_URI_BASE_IDS & """" & ": " & "{");
      Begin_Block;
      NL_And_Indent;

      Write_Str ("""" & URI_Base_Id_Name & """" & ": " & "{");
      Begin_Block;
      NL_And_Indent;

      Write_String_Attribute (N_URI, To_File_Uri (Current_Dir));

      End_Block;
      NL_And_Indent;
      Write_Char ('}');

      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Original_Uri_Base_Ids;

   -----------------------------
   -- Print_Related_Locations --
   -----------------------------

   procedure Print_Related_Locations (E_Msg : Error_Msg_Object) is
      Loc    : Labeled_Span_Type;
      Loc_It : Labeled_Span_Id;

      Sub    : Error_Msg_Object;
      Sub_It : Error_Msg_Id;

      First : Boolean := True;
   begin
      Write_Str ("""" & N_RELATED_LOCATIONS & """" & ": " & "[");
      Begin_Block;

      --  Related locations are the non-primary spans of the diagnostic

      Loc_It := E_Msg.Locations;
      while Loc_It /= No_Labeled_Span loop
         Loc := Locations.Table (Loc_It);

         --  Non-primary spans are considered related locations

         if not Loc.Is_Primary then
            if First then
               First := False;
            else
               Write_Char (',');
            end if;

            NL_And_Indent;
            Print_Location (Loc, Loc.Label);
         end if;
         Loc_It := Loc.Next;
      end loop;

      --  And the sub-diagnostic locations

      Sub_It := E_Msg.Next;
      while Sub_It /= No_Error_Msg and then Errors.Table (Sub_It).Msg_Cont loop
         Sub := Errors.Table (Sub_It);

         declare
            Found : Boolean := False;

            Prim_Loc_Id : Labeled_Span_Id;
         begin
            Prim_Loc_Id := Primary_Location (Sub);

            if Prim_Loc_Id /= No_Labeled_Span then
               Found := True;
            else
               Prim_Loc_Id := Primary_Location (E_Msg);
               Found       := True;
            end if;

            --  For mapping sub-diagnostics to related locations we have to
            --  make some compromises in details.
            --
            --  Firstly we only make one entry that is for the primary span
            --  of the sub-diagnostic.
            --
            --  Secondly this span can also have a label. However this
            --  pattern is not advised and by default we include the message
            --  of the sub-diagnostic as the message in location node since
            --  it should have more information.

            if Found then
               if First then
                  First := False;
               else
                  Write_Char (',');
               end if;
               NL_And_Indent;
               Print_Location (Locations.Table (Prim_Loc_Id), Sub.Text);
            end if;
         end;

         Next_Continuation_Msg (Sub_It);
      end loop;

      End_Block;
      NL_And_Indent;
      Write_Char (']');
   end Print_Related_Locations;

   ------------------
   -- Print_Result --
   ------------------

   procedure Print_Result (E_Msg : Error_Msg_Object) is

   begin
      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      --  Print ruleId

      Write_String_Attribute (N_RULE_ID, "[" & To_String (E_Msg.Id) & "]");

      Write_Char (',');
      NL_And_Indent;

      --  Print level

      Write_String_Attribute (N_LEVEL, Kind_To_String (E_Msg));

      Write_Char (',');
      NL_And_Indent;

      --  Print message

      Print_Message (E_Msg.Text.all);

      Write_Char (',');
      NL_And_Indent;

      --  Print locations

      Print_Locations (E_Msg);

      Write_Char (',');
      NL_And_Indent;

      --  Print related locations

      Print_Related_Locations (E_Msg);

      Write_Char (',');
      NL_And_Indent;

      --  Print fixes

      Print_Fixes (E_Msg);

      End_Block;
      NL_And_Indent;

      Write_Char ('}');
   end Print_Result;

   -------------------
   -- Print_Results --
   -------------------

   procedure Print_Results is
      E : Error_Msg_Id;

      First : Boolean := True;
   begin
      Write_Str ("""" & N_RESULTS & """" & ": " & "[");
      Begin_Block;

      E := First_Error_Msg;
      while E /= No_Error_Msg loop
         if First then
            First := False;
         else
            Write_Char (',');
         end if;

         NL_And_Indent;

         Print_Result (Errors.Table (E));

         Next_Error_Msg (E);
      end loop;

      End_Block;
      NL_And_Indent;
      Write_Char (']');
   end Print_Results;

   ----------------
   -- Print_Rule --
   ----------------

   procedure Print_Rule (E : Error_Msg_Object) is
      Human_Id : constant String_Ptr := Get_Human_Id (E);
   begin
      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      Write_String_Attribute (N_ID, "[" & To_String (E.Id) & "]");
      Write_Char (',');
      NL_And_Indent;

      if Human_Id = null then
         Write_String_Attribute (N_NAME, "Uncategorized_Diagnostic");
      else
         Write_String_Attribute (N_NAME, Human_Id.all);
      end if;

      End_Block;
      NL_And_Indent;
      Write_Char ('}');
   end Print_Rule;

   -----------------
   -- Print_Rules --
   -----------------

   procedure Print_Rules is
      use Error_Msg_Lists;
      R     : Error_Msg_Object;
      Rules : Error_Msg_List := Get_Unique_Rules;
      It    : Iterator       := Iterate (Rules);

      First : Boolean := True;
   begin
      Write_Str ("""" & N_RULES & """" & ": " & "[");
      Begin_Block;

      while Has_Next (It) loop
         Next (It, R);

         if First then
            First := False;
         else
            Write_Char (',');
         end if;

         NL_And_Indent;
         Print_Rule (R);
      end loop;

      End_Block;
      NL_And_Indent;
      Write_Char (']');

      Error_Msg_Lists.Destroy (Rules);
   end Print_Rules;

   ----------------
   -- Print_Tool --
   ----------------

   procedure Print_Tool is

   begin
      Write_Str ("""" & N_TOOL & """" & ": " & "{");
      Begin_Block;
      NL_And_Indent;

      --  --  Attributes of tool

      Write_Str ("""" & N_DRIVER & """" & ": " & "{");
      Begin_Block;
      NL_And_Indent;

      --  Attributes of tool.driver

      Write_String_Attribute (N_NAME, "GNAT");
      Write_Char (',');
      NL_And_Indent;

      Write_String_Attribute (N_VERSION, Gnat_Version_String);
      Write_Char (',');
      NL_And_Indent;

      Print_Rules;

      --  End of tool.driver

      End_Block;
      NL_And_Indent;

      Write_Char ('}');

      --  End of tool

      End_Block;
      NL_And_Indent;

      Write_Char ('}');
   end Print_Tool;

   ----------------
   -- Print_Runs --
   ----------------

   procedure Print_Runs is

   begin
      Write_Str ("""" & N_RUNS & """" & ": " & "[");
      Begin_Block;
      NL_And_Indent;

      --  Runs can consist of multiple "run"-s. However the GNAT SARIF report
      --  only has one.

      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      --  A run consists of a tool

      Print_Tool;

      Write_Char (',');
      NL_And_Indent;

      --  A run consists of an invocation
      Print_Invocations;

      Write_Char (',');
      NL_And_Indent;

      Print_Original_Uri_Base_Ids;
      Write_Char (',');
      NL_And_Indent;

      --  A run consists of results

      Print_Results;

      --  End of run

      End_Block;
      NL_And_Indent;

      Write_Char ('}');

      End_Block;
      NL_And_Indent;

      --  End of runs

      Write_Char (']');
   end Print_Runs;

   ------------------------
   -- Print_SARIF_Report --
   ------------------------

   procedure Print_SARIF_Report is
   begin
      Write_Char ('{');
      Begin_Block;
      NL_And_Indent;

      Write_String_Attribute (N_SCHEMA, SARIF_Schema);
      Write_Char (',');
      NL_And_Indent;

      Write_String_Attribute (N_VERSION, SARIF_Version);
      Write_Char (',');
      NL_And_Indent;

      Print_Runs;

      End_Block;
      NL_And_Indent;
      Write_Char ('}');

      Write_Eol;
   end Print_SARIF_Report;

end Erroutc.SARIF_Emitter;