Merge branch 'mr/pmderodat/unparsing' into 'master'

Unparsing: rework error message handling

See merge request eng/libadalang/langkit!1006

Author: pmderodat

langkit/support/langkit_support-diagnostics.adb

@@ -3,20 +3,34 @@
 --  SPDX-License-Identifier: Apache-2.0
 --
 
+with Ada.Text_IO; use Ada.Text_IO;
+
 package body Langkit_Support.Diagnostics is
 
+   function Sloc_Prefix (Sloc_Range : Source_Location_Range) return String;
+   --  If ``Sloc_Range`` is not null, return a "X:Y: " prefix with the
+   --  corresponding start line/column numbers.
+
+   -----------------
+   -- Sloc_Prefix --
+   -----------------
+
+   function Sloc_Prefix (Sloc_Range : Source_Location_Range) return String is
+      Sloc : constant Source_Location := Start_Sloc (Sloc_Range);
+   begin
+      return
+        (if Sloc = No_Source_Location
+         then ""
+         else Image (Sloc) & ": ");
+   end Sloc_Prefix;
+
    ----------------------
    -- To_Pretty_String --
    ----------------------
 
    function To_Pretty_String (D : Diagnostic) return String is
-      Sloc        : constant Source_Location := Start_Sloc (D.Sloc_Range);
-      Sloc_Prefix : constant String :=
-        (if Sloc = No_Source_Location
-         then ""
-         else Image (Sloc) & ": ");
    begin
-      return Sloc_Prefix & Image (To_Text (D.Message));
+      return Sloc_Prefix (D.Sloc_Range) & Image (To_Text (D.Message));
    end To_Pretty_String;
 
    ------------
@@ -58,4 +72,37 @@ package body Langkit_Support.Diagnostics is
       Append (Diagnostics, Sloc_Range, To_Text (Msg));
    end Append;
 
+   -----------
+   -- Print --
+   -----------
+
+   procedure Print
+     (Diagnostics : Diagnostics_Vectors.Vector;
+      Prefix      : String := "error: ";
+      Indent      : Natural := 2) is
+   begin
+      for D of Diagnostics loop
+         Put (Sloc_Prefix (D.Sloc_Range));
+         Put (Prefix);
+         declare
+            Empty_Line : Boolean := False;
+            Msg        : constant String := To_UTF8 (To_Text (D.Message));
+         begin
+            for C of Msg loop
+               if C = ASCII.LF then
+                  New_Line;
+                  Empty_Line := True;
+               else
+                  if Empty_Line then
+                     Put ((1 .. Indent => ' '));
+                     Empty_Line := False;
+                  end if;
+                  Put (C);
+               end if;
+            end loop;
+         end;
+         New_Line;
+      end loop;
+   end Print;
+
 end Langkit_Support.Diagnostics;

langkit/support/langkit_support-diagnostics.ads

@@ -52,4 +52,12 @@ package Langkit_Support.Diagnostics is
       Exc         : Ada.Exceptions.Exception_Occurrence);
    --  Shortcut to append an exception message to a vector
 
+   procedure Print
+     (Diagnostics : Diagnostics_Vectors.Vector;
+      Prefix      : String := "error: ";
+      Indent      : Natural := 2);
+   --  Print all diagnostics in ``Diagnostics`` on the standard output, with
+   --  ``Prefix`` before each message. For multi-line messages, insert
+   --  ``Indent`` spaces before each line except the first one.
+
 end Langkit_Support.Diagnostics;

langkit/support/langkit_support-generic_api-unparsing.adb

@@ -6,7 +6,6 @@
 with Ada.Command_Line;
 with Ada.Containers.Hashed_Maps;
 with Ada.Containers.Vectors;
-with Ada.Exceptions;           use Ada.Exceptions;
 with Ada.Strings.Unbounded;    use Ada.Strings.Unbounded;
 with Ada.Text_IO;              use Ada.Text_IO;
 with Ada.Text_IO.Unbounded_IO; use Ada.Text_IO.Unbounded_IO;
@@ -28,6 +27,7 @@ use Langkit_Support.Internal.Descriptor;
 with Langkit_Support.Internal.Unparsing;
 use Langkit_Support.Internal.Unparsing;
 with Langkit_Support.Prettier_Utils; use Langkit_Support.Prettier_Utils;
+with Langkit_Support.Slocs;          use Langkit_Support.Slocs;
 with Langkit_Support.Symbols;        use Langkit_Support.Symbols;
 
 package body Langkit_Support.Generic_API.Unparsing is
@@ -480,7 +480,10 @@ package body Langkit_Support.Generic_API.Unparsing is
    ---------------------------
 
    function Load_Unparsing_Config
-     (Language : Language_Id; Filename : String) return Unparsing_Configuration
+     (Language    : Language_Id;
+      Filename    : String;
+      Diagnostics : in out Diagnostics_Vectors.Vector)
+      return Unparsing_Configuration
    is
       --  Create a map so that we can lookup nodes/fields by name
 
@@ -618,6 +621,10 @@ package body Langkit_Support.Generic_API.Unparsing is
       --  Assuming that JSON is the "fields" configuration for Node, parse its
       --  field configurations and set Configs accordingly.
 
+      procedure Abort_Parsing (Message : String) with No_Return;
+      --  Append an item to ``Diagnostics`` and raise an Invalid_Input
+      --  exception.
+
       Result : constant Unparsing_Configuration_Access :=
         new Unparsing_Configuration_Record;
       Pool   : Document_Pool renames Result.Pool;
@@ -630,7 +637,7 @@ package body Langkit_Support.Generic_API.Unparsing is
          T : constant Type_Ref := Map.Lookup_Type (To_Symbol (Name));
       begin
          if T = No_Type_Ref or else not Is_Node_Type (T) then
-            raise Invalid_Input with "invalid node name: " & Name;
+            Abort_Parsing ("invalid node name: " & Name);
          end if;
          return To_Index (T);
       end To_Type_Index;
@@ -646,14 +653,14 @@ package body Langkit_Support.Generic_API.Unparsing is
            Map.Lookup_Struct_Member (Node, To_Symbol (Name));
       begin
          if M = No_Struct_Member_Ref then
-            raise Invalid_Input with
-              "invalid field for " & Node_Type_Image (Node) & ": " & Name;
+            Abort_Parsing
+              ("invalid field for " & Node_Type_Image (Node) & ": " & Name);
          elsif not Is_Field (M) then
-            raise Invalid_Input with
-              Name & " is not a syntax field for " & Node_Type_Image (Node);
+            Abort_Parsing
+              (Name & " is not a syntax field for " & Node_Type_Image (Node));
          elsif Is_Null_For (M, Node) then
-            raise Invalid_Input with
-              Name & " is a null field for " & Node_Type_Image (Node);
+            Abort_Parsing
+              (Name & " is a null field for " & Node_Type_Image (Node));
          else
             return To_Index (M);
          end if;
@@ -1168,7 +1175,7 @@ package body Langkit_Support.Generic_API.Unparsing is
             when Field_Template =>
               "template for " & Field_Image (Context.Field, Context.Node));
       begin
-         raise Invalid_Input with Prefix & ": " & Message;
+         Abort_Parsing (Prefix & ": " & Message);
       end Abort_Parsing;
 
       --------------------------
@@ -1220,6 +1227,16 @@ package body Langkit_Support.Generic_API.Unparsing is
          JSON.Map_JSON_Object (Process'Access);
       end Load_Field_Configs;
 
+      -------------------
+      -- Abort_Parsing --
+      -------------------
+
+      procedure Abort_Parsing (Message : String) is
+      begin
+         Append (Diagnostics, No_Source_Location_Range, To_Text (Message));
+         raise Invalid_Input;
+      end Abort_Parsing;
+
       use type GNAT.Strings.String_Access;
 
       --  First, parse the JSON document
@@ -1229,16 +1246,27 @@ package body Langkit_Support.Generic_API.Unparsing is
       JSON        : JSON_Value;
    begin
       if JSON_Text = null then
-         raise Invalid_Input with "cannot read " & Filename;
+         Abort_Parsing ("cannot read " & Filename);
       end if;
       JSON_Result := Read (JSON_Text.all);
       GNAT.Strings.Free (JSON_Text);
 
       if JSON_Result.Success then
          JSON := JSON_Result.Value;
       else
-         raise Invalid_Input with
-           Filename & ":" & Format_Parsing_Error (JSON_Result.Error);
+         declare
+            Sloc       : constant Source_Location :=
+              (Line_Number (JSON_Result.Error.Line),
+               Column_Number (JSON_Result.Error.Column));
+            Sloc_Range : constant Source_Location_Range :=
+              Make_Range (Sloc, Sloc);
+         begin
+            Append
+              (Diagnostics,
+               Sloc_Range,
+               To_Text (To_String (JSON_Result.Error.Message)));
+            raise Invalid_Input;
+         end;
       end if;
 
       --  Then load the unparsing configuration from it. Require a
@@ -1248,7 +1276,7 @@ package body Langkit_Support.Generic_API.Unparsing is
       Result.Language := Language;
 
       if not JSON.Has_Field ("node_configs") then
-         raise Invalid_Input with "missing ""node_configs"" key";
+         Abort_Parsing ("missing ""node_configs"" key");
       end if;
 
       declare
@@ -1288,9 +1316,9 @@ package body Langkit_Support.Generic_API.Unparsing is
 
             if Value.Has_Field ("sep") then
                if not Is_List_Node (Node) then
-                  raise Invalid_Input with
-                    Name & " is not a list node, invalid ""sep"""
-                    & " configuration";
+                  Abort_Parsing
+                    (Name & " is not a list node, invalid ""sep"""
+                     & " configuration");
                end if;
                declare
                   Context : Template_Parsing_Context :=
@@ -1395,8 +1423,9 @@ package body Langkit_Support.Generic_API.Unparsing is
 
    exception
       when Invalid_Input =>
+         pragma Assert (not Diagnostics.Is_Empty);
          Destroy (Symbols);
-         raise;
+         return No_Unparsing_Configuration;
    end Load_Unparsing_Config;
 
    --------------------------
@@ -1854,14 +1883,16 @@ package body Langkit_Support.Generic_API.Unparsing is
       --  Parse the configuration file and the source file to pretty-print.
       --  Abort if there is a parsing failure.
 
+      declare
+         Diagnostics : Diagnostics_Vectors.Vector;
+         Filename    : constant String := To_String (Config_Filename.Get);
       begin
-         Config :=
-           Load_Unparsing_Config (Language, To_String (Config_Filename.Get));
-      exception
-         when Exc : Invalid_Input =>
+         Config := Load_Unparsing_Config (Language, Filename, Diagnostics);
+         if Config = No_Unparsing_Configuration then
             Put_Line ("Error when loading the unparsing configuration:");
-            Put_Line (Exception_Message (Exc));
+            Print (Diagnostics);
             return;
+         end if;
       end;
       Context := Create_Context (Language);
       Unit := Context.Get_From_File

langkit/support/langkit_support-generic_api-unparsing.ads

@@ -20,6 +20,7 @@
 --     with Ada.Text_IO;              use Ada.Text_IO;
 --     with Ada.Text_IO.Unbounded_IO; use Ada.Text_IO.Unbounded_IO;
 --
+--     with Langkit_Support.Diagnostics; use Langkit_Support.Diagnostics;
 --     with Langkit_Support.Generic_API; use Langkit_Support.Generic_API;
 --     with Langkit_Support.Generic_API.Analysis;
 --     use Langkit_Support.Generic_API.Analysis;
@@ -38,8 +39,9 @@
 --        --  Load_Unparsing_Config function for more information about this
 --        --  file.
 --
---        Config : constant Unparsing_Configuration :=
---           Load_Unparsing_Config (Self_Id, "config.json");
+--        Diagnostics : Diagnostics_Vectors.Vector;
+--        Config      : constant Unparsing_Configuration :=
+--           Load_Unparsing_Config (Self_Id, "config.json", Diagnostics);
 --
 --        --  Parse the source file to reformat
 --
@@ -48,7 +50,15 @@
 --        U   : constant Lk_Unit :=
 --          Ctx.Get_From_File (Ada.Command_Line.Argument (1));
 --     begin
---        --  If it has parsing errors, bail out
+--        --  If we were unable to load the unparsing configuration, bail out
+--
+--        if Config = No_Unparsing_Configuration then
+--           Put_Line ("Error when loading the unparsing configuration:");
+--           Print (Diagnostics);
+--           raise Program_Error;
+--        end if;
+--
+--        --  If the source file to reformat has parsing errors, bail out
 --
 --        if U.Has_Diagnostics then
 --           Put_Line ("Parsing errors:");
@@ -74,6 +84,7 @@ private with Ada.Finalization;
 
 with Prettier_Ada.Documents;
 
+with Langkit_Support.Diagnostics; use Langkit_Support.Diagnostics;
 with Langkit_Support.Generic_API.Analysis;
 use Langkit_Support.Generic_API.Analysis;
 
@@ -83,12 +94,18 @@ package Langkit_Support.Generic_API.Unparsing is
    --  Configuration that customizes how source fragments are turned into a
    --  prettier document.
 
+   No_Unparsing_Configuration : constant Unparsing_Configuration;
+   --  Special value to mean the absence of an unparsing configuration
+
    function Load_Unparsing_Config
-     (Language : Language_Id;
-      Filename : String) return Unparsing_Configuration;
+     (Language    : Language_Id;
+      Filename    : String;
+      Diagnostics : in out Diagnostics_Vectors.Vector)
+      return Unparsing_Configuration;
    --  Read and parse the unparsing configuration for the given Language from
-   --  Filename. Raise a Langkit_Support.Errors.Invalid_Input exception if an
-   --  error occurs while reading the configuration file.
+   --  Filename. Append error messages to ``Diagnostics`` and return
+   --  ``No_Unparsing_Configuration`` if an error occurs while reading the
+   --  configuration file.
    --
    --  The configuration is a JSON file that provides "document templates":
    --  patterns to generate Prettier documents:
@@ -286,4 +303,7 @@ private
    overriding procedure Adjust (Self : in out Unparsing_Configuration);
    overriding procedure Finalize (Self : in out Unparsing_Configuration);
 
+   No_Unparsing_Configuration : constant Unparsing_Configuration :=
+     (Ada.Finalization.Controlled with Value => null);
+
 end Langkit_Support.Generic_API.Unparsing;

testsuite/tests/ada_api/unparsing/commands.adb

@@ -6,6 +6,7 @@ with GNATCOLL.JSON; use GNATCOLL.JSON;
 with Prettier_Ada.Documents;
 with Prettier_Ada.Documents.Json;
 
+with Langkit_Support.Diagnostics; use Langkit_Support.Diagnostics;
 with Langkit_Support.Generic_API.Analysis;
 use Langkit_Support.Generic_API.Analysis;
 with Langkit_Support.Generic_API.Unparsing;
@@ -42,7 +43,15 @@ procedure Commands is
          raise Program_Error;
       end if;
 
-      Config := Load_Unparsing_Config (Self_Id, Filename);
+      declare
+         Diagnostics : Diagnostics_Vectors.Vector;
+      begin
+         Config := Load_Unparsing_Config (Self_Id, Filename, Diagnostics);
+         if Config = No_Unparsing_Configuration then
+            Print (Diagnostics);
+            raise Program_Error;
+         end if;
+      end;
       Doc := Unparse_To_Prettier (Unit.Root, Config);
       JSON_Text := Prettier_Ada.Documents.Json.Serialize (Doc);