Unparsing: rework error message handling

Use the diagnostics data structures defined in Langkit_Support to hold
error messages for the loading of unparsing configuration. We previously
used exception messages, which have several limitations: length limit
(exception messages are truncated) and no possibility to have multiple
error messages.

Using actual diagnostics also allows to have slocs associated to error
messages, which will be useful once the unparsing configuration
transition from JSON to a proper DSL (GNATCOLL.JSON does not gives slocs
for JSON data).

This commit also adds the Langkit_Support.Diagnostics.Print procedure as
a convenient helper to print lists of diagnostics encoded in UTF-8.

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);