Merge branch 'topic/on_error' into 'master'

Add `--on-hang-script` option to `tester-run`

See merge request eng/ide/ada_language_server!1120

Author: reznikmm

README.md

@@ -15,7 +15,7 @@ Current features:
 * [GNAT project files](https://docs.adacore.com/gprbuild-docs/html/gprbuild_ug/gnat_project_manager.html) support.
 * Code completion for names, keywords, aggregates, etc.
 * Code navigation, such as Go to Definition/Declaration, Find All References, Call Hierarchies, etc.
-* Code refactoring like insert named associations, auto-add `with`-clauses.
+* [Code refactoring](#refactoring-tools) like insert named associations, auto-add `with`-clauses, etc.
 * Document/Workspace symbol search.
 * Code folding and formatting.
 
@@ -97,7 +97,8 @@ You can turn some debugging and experimental features trought
 [the traces file](doc/traces.md).
 
 The server also gets configuration via `workspace/didChangeConfiguration`
-notification. See more [details here](doc/settings.md). Each LSP
+notification and `initializationOptions` of `initialize` request.
+See more [details here](doc/settings.md). Each LSP
 client provides its-own way to set such settings.
 
 ## Supported LSP Server Requests

source/client/lsp-raw_clients.adb

@@ -1,7 +1,7 @@
 ------------------------------------------------------------------------------
 --                         Language Server Protocol                         --
 --                                                                          --
---                     Copyright (C) 2018-2021, AdaCore                     --
+--                     Copyright (C) 2018-2023, 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- --
@@ -133,6 +133,15 @@ package body LSP.Raw_Clients is
       end if;
    end Send_Message;
 
+   ----------------
+   -- Server_PID --
+   ----------------
+
+   function Server_PID (Self : Raw_Client'Class) return String is
+   begin
+      return Self.Server.Identifier;
+   end Server_PID;
+
    -------------------
    -- Set_Arguments --
    -------------------

source/client/lsp-raw_clients.ads

@@ -114,6 +114,9 @@ package LSP.Raw_Clients is
    --  Return True when server's process is running and send queue is empty,
    --  thus send operation can start immidiately.
 
+   function Server_PID (Self : Raw_Client'Class) return String;
+   --  Return server process id (pid) if the server has been started.
+
 private
    type Listener (Client : access Raw_Client'Class) is limited
      new Spawn.Processes.Process_Listener with null record;

source/tester/tester-run.adb

@@ -1,7 +1,7 @@
 ------------------------------------------------------------------------------
 --                         Language Server Protocol                         --
 --                                                                          --
---                     Copyright (C) 2018-2019, AdaCore                     --
+--                     Copyright (C) 2018-2023, 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- --
@@ -21,35 +21,72 @@ with Ada.Strings.Unbounded;
 with Ada.Text_IO;
 with GNATCOLL.JSON;
 
-with Tester.Macros;
-with Tester.Tests;
+with VSS.Command_Line;
+with VSS.Strings;
+with VSS.Strings.Conversions;
+with VSS.String_Vectors;
 
 with Spawn.Environments;
 
+with Tester.Macros;
+with Tester.Tests;
+
 procedure Tester.Run is
+
+   package Options is
+      --  Command line options and arguments
+
+      Debug : constant VSS.Command_Line.Binary_Option :=
+        (Short_Name  => "d",
+         Long_Name   => "debug",
+         Description => "disable timeouts then pause after server start");
+
+      On_Hang : constant VSS.Command_Line.Value_Option :=
+        (Short_Name  => "",
+         Long_Name   => "on-hang-script",
+         Value_Name  => "command_and_args",
+         Description => "the command to launch if the test hangs");
+
+      File  : constant VSS.Command_Line.Positional_Option :=
+        (Name  => "test.json",
+         Description => "JSON test script");
+   end Options;
+
    Env  : constant Spawn.Environments.Process_Environment :=
      Spawn.Environments.System_Environment;
 
    JSON : GNATCOLL.JSON.JSON_Value;
 begin
-   if not (Ada.Command_Line.Argument_Count = 1
-     or else (Ada.Command_Line.Argument_Count = 2
-              and then Ada.Command_Line.Argument (1) = "--debug"))
-   then
-      Ada.Text_IO.Put_Line ("Usage:");
-      Ada.Text_IO.Put_Line
-        ("   " & Ada.Command_Line.Command_Name & " [options] test.json");
-      Ada.Text_IO.New_Line;
-      Ada.Text_IO.Put_Line ("Options are:");
-      Ada.Text_IO.Put_Line
-        ("  --debug  disable timeouts and pause after server start");
-      Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
-      return;
+   VSS.Command_Line.Add_Option (Options.Debug);
+   VSS.Command_Line.Add_Option (Options.On_Hang);
+   VSS.Command_Line.Add_Option (Options.File);
+   VSS.Command_Line.Process;  --  This terminates process on option's error
+
+   if not Options.File.Is_Specified then
+      declare
+         use type VSS.Strings.Virtual_String;
+         Usage : VSS.String_Vectors.Virtual_String_Vector;
+      begin
+         Usage.Append ("Usage:");
+         Usage.Append
+           ("   tester-run [options] " & Options.File.Name);
+         Usage.Append ("");
+         Usage.Append ("Options are:");
+         Usage.Append
+           ("  --" & Options.Debug.Long_Name
+            & " (-" & Options.Debug.Short_Name & ")"
+            & "  " & Options.Debug.Description);
+         Usage.Append
+           ("  --" & Options.On_Hang.Long_Name
+            & "=" & Options.On_Hang.Value_Name
+            & "  " & Options.On_Hang.Description);
+         VSS.Command_Line.Report_Error (Usage.Join_Lines (VSS.Strings.LF));
+      end;
    end if;
 
    declare
-      File  : constant String := Ada.Command_Line.Argument
-        (Ada.Command_Line.Argument_Count);
+      File  : constant String := VSS.Strings.Conversions.To_UTF_8_String
+        (Options.File.Value);
       Input : Ada.Text_IO.File_Type;
       Text  : Ada.Strings.Unbounded.Unbounded_String;
    begin
@@ -73,7 +110,10 @@ begin
       declare
          Test : Tester.Tests.Test;
       begin
-         Test.Run (JSON.Get, Debug => Ada.Command_Line.Argument_Count = 2);
+         Test.Run
+           (JSON.Get,
+            On_Hang => Options.On_Hang.Value,
+            Debug   => Options.Debug.Is_Specified);
       end;
    end;
 end Tester.Run;