W119-049 Add --on-hang-script option to tester-run

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

@@ -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

@@ -41,6 +41,12 @@ procedure Tester.Run is
          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");
@@ -52,6 +58,7 @@ procedure Tester.Run is
    JSON : GNATCOLL.JSON.JSON_Value;
 begin
    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
 
@@ -69,6 +76,10 @@ begin
            ("  --" & 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;
@@ -99,7 +110,10 @@ begin
       declare
          Test : Tester.Tests.Test;
       begin
-         Test.Run (JSON.Get, Debug => Options.Debug.Is_Specified);
+         Test.Run
+           (JSON.Get,
+            On_Hang => Options.On_Hang.Value,
+            Debug   => Options.Debug.Is_Specified);
       end;
    end;
 end Tester.Run;