Fix broken early configuration

reznikmm · reznikmm · commit 3db59a70bbe7 · 2023-03-01T11:46:29.000Z
when Self.Root hasn't been set yet by Initialize request, but Change_Configuration relies on it. Refs #1108
diff --git a/source/ada/lsp-ada_driver.adb b/source/ada/lsp-ada_driver.adb
@@ -354,7 +354,9 @@ begin
             GNAT.OS_Lib.OS_Exit (1);
          end if;
 
-         Ada_Handler.Change_Configuration (Parse_Result.Value);
+         Ada_Handler.Change_Configuration_Before_Init
+           (Options => Parse_Result.Value,
+            Root    => Config_File.Dir);
       end;
    end if;
 
diff --git a/source/ada/lsp-ada_handlers.adb b/source/ada/lsp-ada_handlers.adb
@@ -108,6 +108,7 @@ with Libadalang.Preprocessing;
 with URIs;
 
 package body LSP.Ada_Handlers is
+   use GNATCOLL.VFS;
 
    type Cancel_Countdown is mod 128;
    --  Counter to restrict frequency of Request.Canceled checks
@@ -4307,11 +4308,16 @@ package body LSP.Ada_Handlers is
         (Name    : String;
          Default : VSS.Strings.Virtual_String)
            return VSS.Strings.Virtual_String is
-             (if Options.Has_Field (Name)
+             (if Options.Kind = GNATCOLL.JSON.JSON_Object_Type
+                and then Options.Has_Field (Name)
               then VSS.Strings.Conversions.To_Virtual_String
                      (String'(Options.Get (Name)))
               else Default);
 
+      function Has_Field (Name : String) return Boolean is
+         (Options.Kind = GNATCOLL.JSON.JSON_Object_Type
+          and then Options.Has_Field (Name));
+
       ------------------
       -- Add_Variable --
       ------------------
@@ -4336,110 +4342,100 @@ package body LSP.Ada_Handlers is
 
       Has_Variables : Boolean := False;  --  settings has scenarioVariables
 
-      --  Is client capable of dynamically registering file operations?
-      Dynamically_Register_File_Operations : constant Boolean :=
-        Self.Client.capabilities.workspace.fileOperations.Is_Set
-        and then Self.Client.capabilities.workspace.fileOperations.
-                   Value.dynamicRegistration.Is_Set = True;
-
    begin
-      if Options.Kind = GNATCOLL.JSON.JSON_Object_Type then
-         Variables.Names.Clear;
-         Variables.Values.Clear;
-         Relocate_Build_Tree :=
-           Property (relocateBuildTree, Self.Relocate_Build_Tree);
-
-         Relocate_Root := Property (rootDir, Self.Relocate_Root_Dir);
-         Charset := Property (defaultCharset, Self.Charset);
-         File := Property (projectFile, Self.Project_File);
-
-         --  Drop uri scheme if present
-         if File.Starts_With ("file:") then
-            File := Self.URI_To_File (File);
-         end if;
+      Relocate_Build_Tree :=
+        Property (relocateBuildTree, Self.Relocate_Build_Tree);
 
-         if Options.Has_Field (scenarioVariables) and then
-           Options.Get
-             (scenarioVariables).Kind  = GNATCOLL.JSON.JSON_Object_Type
-         then
-            Options.Get
-              (scenarioVariables).Map_JSON_Object (Add_Variable'Access);
-            Has_Variables := True;
-         end if;
+      Relocate_Root := Property (rootDir, Self.Relocate_Root_Dir);
+      Charset := Property (defaultCharset, Self.Charset);
+      File := Property (projectFile, Self.Project_File);
 
-         --  It looks like the protocol does not allow clients to say whether
-         --  or not they want diagnostics as part of
-         --  InitializeParams.capabilities.textDocument. So we support
-         --  deactivating of diagnostics via a setting here.
-         if Options.Has_Field (enableDiagnostics) then
-            Self.Diagnostics_Enabled := Options.Get (enableDiagnostics);
-         end if;
+      --  Drop uri scheme if present
+      if File.Starts_With ("file:") then
+         File := Self.URI_To_File (File);
+      end if;
 
-         --  Similarly to diagnostics, we support selectively activating
-         --  indexing in the parameters to this request.
-         if Options.Has_Field (enableIndexing) then
-            Self.Indexing_Enabled := Options.Get (enableIndexing);
-         end if;
+      if Has_Field (scenarioVariables) and then
+        Options.Get
+          (scenarioVariables).Kind  = GNATCOLL.JSON.JSON_Object_Type
+      then
+         Options.Get
+           (scenarioVariables).Map_JSON_Object (Add_Variable'Access);
+         Has_Variables := True;
+      end if;
 
-         --  Retrieve the different textDocument/rename options if specified
+      --  It looks like the protocol does not allow clients to say whether
+      --  or not they want diagnostics as part of
+      --  InitializeParams.capabilities.textDocument. So we support
+      --  deactivating of diagnostics via a setting here.
+      if Has_Field (enableDiagnostics) then
+         Self.Diagnostics_Enabled := Options.Get (enableDiagnostics);
+      end if;
 
-         if Options.Has_Field (renameInComments) then
-            Self.Options.Refactoring.Renaming.In_Comments :=
-              Options.Get (renameInComments);
-         end if;
+      --  Similarly to diagnostics, we support selectively activating
+      --  indexing in the parameters to this request.
+      if Has_Field (enableIndexing) then
+         Self.Indexing_Enabled := Options.Get (enableIndexing);
+      end if;
 
-         if Options.Has_Field (foldComments) then
-            Self.Options.Folding.Comments := Options.Get (foldComments);
-         end if;
+      --  Retrieve the different textDocument/rename options if specified
 
-         --  Retrieve the number of parameters / components at which point
-         --  named notation is used for subprogram/aggregate completion
-         --  snippets.
+      if Has_Field (renameInComments) then
+         Self.Options.Refactoring.Renaming.In_Comments :=
+           Options.Get (renameInComments);
+      end if;
 
-         if Options.Has_Field (namedNotationThreshold) then
-            Self.Named_Notation_Threshold :=
-              Options.Get (namedNotationThreshold);
-         end if;
+      if Has_Field (foldComments) then
+         Self.Options.Folding.Comments := Options.Get (foldComments);
+      end if;
 
-         if Options.Has_Field (logThreshold) then
-            Self.Log_Threshold := Options.Get (logThreshold);
-         end if;
+      --  Retrieve the number of parameters / components at which point
+      --  named notation is used for subprogram/aggregate completion
+      --  snippets.
 
-         --  Check the 'useCompletionSnippets' flag to see if we should use
-         --  snippets in completion (if the client supports it).
-         if not Self.Completion_Snippets_Enabled then
-            Self.Use_Completion_Snippets := False;
-         elsif Options.Has_Field (useCompletionSnippets) then
-            Self.Use_Completion_Snippets :=
-              Options.Get (useCompletionSnippets);
-         end if;
+      if Has_Field (namedNotationThreshold) then
+         Self.Named_Notation_Threshold :=
+           Options.Get (namedNotationThreshold);
+      end if;
 
-         --  Retrieve the policy for displaying type hierarchy on navigation
-         --  requests.
-         if Options.Has_Field (displayMethodAncestryOnNavigation) then
-            Self.Display_Method_Ancestry_Policy :=
-              LSP.Messages.AlsDisplayMethodAncestryOnNavigationPolicy'Value
-                (Options.Get (displayMethodAncestryOnNavigation));
-         end if;
+      if Has_Field (logThreshold) then
+         Self.Log_Threshold := Options.Get (logThreshold);
+      end if;
 
-         --  Retrieve the follow symlinks policy.
+      --  Check the 'useCompletionSnippets' flag to see if we should use
+      --  snippets in completion (if the client supports it).
+      if not Self.Completion_Snippets_Enabled then
+         Self.Use_Completion_Snippets := False;
+      elsif Has_Field (useCompletionSnippets) then
+         Self.Use_Completion_Snippets :=
+           Options.Get (useCompletionSnippets);
+      end if;
 
-         if Options.Has_Field (followSymlinks) then
-            Self.Follow_Symlinks := Options.Get (followSymlinks);
-         end if;
+      --  Retrieve the policy for displaying type hierarchy on navigation
+      --  requests.
+      if Has_Field (displayMethodAncestryOnNavigation) then
+         Self.Display_Method_Ancestry_Policy :=
+           LSP.Messages.AlsDisplayMethodAncestryOnNavigationPolicy'Value
+             (Options.Get (displayMethodAncestryOnNavigation));
+      end if;
 
-         if Options.Has_Field (documentationStyle) then
-            begin
-               Self.Options.Documentation.Style :=
-                 GNATdoc.Comments.Options.Documentation_Style'Value
-                   (Options.Get (documentationStyle));
+      --  Retrieve the follow symlinks policy.
 
-            exception
-               when Constraint_Error =>
-                  Self.Options.Documentation.Style :=
-                    GNATdoc.Comments.Options.GNAT;
-            end;
-         end if;
+      if Has_Field (followSymlinks) then
+         Self.Follow_Symlinks := Options.Get (followSymlinks);
+      end if;
+
+      if Has_Field (documentationStyle) then
+         begin
+            Self.Options.Documentation.Style :=
+              GNATdoc.Comments.Options.Documentation_Style'Value
+                (Options.Get (documentationStyle));
+
+         exception
+            when Constraint_Error =>
+               Self.Options.Documentation.Style :=
+                 GNATdoc.Comments.Options.GNAT;
+         end;
       end if;
 
       if Self.Project_File = File
@@ -4464,6 +4460,43 @@ package body LSP.Ada_Handlers is
          Self.Project_Status := Valid_Project_Configured;
          Self.Reload_Project;
       end if;
+   end Change_Configuration;
+
+   --------------------------------------
+   -- Change_Configuration_Before_Init --
+   --------------------------------------
+
+   procedure Change_Configuration_Before_Init
+     (Self    : access Message_Handler;
+      Options : GNATCOLL.JSON.JSON_Value'Class;
+      Root    : GNATCOLL.VFS.Virtual_File)
+   is
+      Saved_Root : constant GNATCOLL.VFS.Virtual_File := Self.Root;
+   begin
+      Self.Root := Root;
+      Self.Change_Configuration (Options);
+      Self.Root := Saved_Root;
+   end Change_Configuration_Before_Init;
+
+   --------------------------------------------
+   -- On_DidChangeConfiguration_Notification --
+   --------------------------------------------
+
+   overriding procedure On_DidChangeConfiguration_Notification
+     (Self  : access Message_Handler;
+      Value : LSP.Messages.DidChangeConfigurationParams)
+   is
+
+      Ada       : constant LSP.Types.LSP_Any := Value.settings.Get ("ada");
+
+      --  Is client capable of dynamically registering file operations?
+      Dynamically_Register_File_Operations : constant Boolean :=
+        Self.Client.capabilities.workspace.fileOperations.Is_Set
+        and then Self.Client.capabilities.workspace.fileOperations.
+                   Value.dynamicRegistration.Is_Set = True;
+
+   begin
+      Self.Change_Configuration (Ada);
 
       --  Register rangeFormatting provider is the client supports
       --  dynamic registration for it (and we haven't done it before).
@@ -4550,21 +4583,6 @@ package body LSP.Ada_Handlers is
             Self.Server.On_RegisterCapability_Request (Request);
          end;
       end if;
-   end Change_Configuration;
-
-   --------------------------------------------
-   -- On_DidChangeConfiguration_Notification --
-   --------------------------------------------
-
-   overriding procedure On_DidChangeConfiguration_Notification
-     (Self  : access Message_Handler;
-      Value : LSP.Messages.DidChangeConfigurationParams)
-   is
-
-      Ada       : constant LSP.Types.LSP_Any := Value.settings.Get ("ada");
-
-   begin
-      Self.Change_Configuration (Ada);
    end On_DidChangeConfiguration_Notification;
 
    -------------------------------------------
diff --git a/source/ada/lsp-ada_handlers.ads b/source/ada/lsp-ada_handlers.ads
@@ -24,7 +24,7 @@ with Ada.Strings.Unbounded;
 with VSS.String_Vectors;
 
 with GNATCOLL.JSON;
-with GNATCOLL.VFS;    use GNATCOLL.VFS;
+with GNATCOLL.VFS;
 with GNATCOLL.Traces;
 
 with VSS.Strings;
@@ -77,19 +77,29 @@ package LSP.Ada_Handlers is
       Options : GNATCOLL.JSON.JSON_Value'Class);
    --  Change server configuration with settings from Ada JSON object.
 
+   procedure Change_Configuration_Before_Init
+     (Self    : access Message_Handler;
+      Options : GNATCOLL.JSON.JSON_Value'Class;
+      Root    : GNATCOLL.VFS.Virtual_File);
+   --  Change server configuration with settings from Ada JSON object, taking
+   --  Root to resolve all relative references. This is expected to work
+   --  before the server get initialize request and find root folder.
+
    procedure Stop_File_Monitoring (Self : access Message_Handler);
 
    procedure Cleanup (Self : access Message_Handler);
    --  Free memory referenced by Self
 
-   procedure Clean_Logs (Self : access Message_Handler; Dir : Virtual_File);
+   procedure Clean_Logs
+     (Self : access Message_Handler;
+      Dir  : GNATCOLL.VFS.Virtual_File);
    --  Remove the oldest logs in Dir
 
    subtype Context_Access is LSP.Ada_Context_Sets.Context_Access;
 
    function From_File
      (Self : Message_Handler'Class;
-      File : Virtual_File) return LSP.Messages.DocumentUri;
+      File : GNATCOLL.VFS.Virtual_File) return LSP.Messages.DocumentUri;
    --  Turn Virtual_File to URI
 
    function To_File
@@ -260,7 +270,7 @@ private
       Client : LSP.Messages.InitializeParams;
       --  Client settings got during initialization request
 
-      Root : Virtual_File;
+      Root : GNATCOLL.VFS.Virtual_File;
       --  The directory passed under rootURI/rootPath during the initialize
       --  request.
 
