Handle textDocument/definition queries on 'is' token

AnthonyLeonardoGracio · AnthonyLeonardoGracio · commit accd2e139092 · 2025-10-10T10:13:59.000Z
And jump to the private part of packages, task bodies,
subprogram bodies ('begin' keyword) etc.

For eng/ide/ada_language_server#1679
diff --git a/source/ada/lsp-ada_definition.adb b/source/ada/lsp-ada_definition.adb
@@ -24,6 +24,7 @@ with Libadalang.Common;
 with Laltools.Common;
 
 with LSP.Ada_Context_Sets;
+with LSP.Ada_Documents;
 with LSP.Ada_Handlers.Locations;
 with LSP.Ada_Request_Jobs;
 with LSP.Client_Message_Receivers;
@@ -124,6 +125,132 @@ package body LSP.Ada_Definition is
       Decl_For_Find_Overrides : Libadalang.Analysis.Basic_Decl;
 
       Ignore : Boolean;
+
+      procedure Retrieve_Alternate_Part_Location;
+      --  Retrieve the location of the alternate part of a package, task,
+      --  protected type, or subprogram.
+      --  This is used when the user queries the definition of a token that
+      --  does not belong to a defining name.
+      --  If the queried token is equal to 'is', retrieve the location of the
+      --  private part of the package, task, protected type, or the begin
+      --  of the subprogram body.
+
+      procedure Retrieve_Alternate_Part_Location is
+         use Libadalang.Common;
+
+         procedure Append_Prev_Token_Location
+           (Node : Libadalang.Analysis.Ada_Node'Class);
+         --  Append the previous token's location to the response.
+
+         -----------------------
+         -- Append_Prev_Token --
+         -----------------------
+
+         procedure Append_Prev_Token_Location
+           (Node : Libadalang.Analysis.Ada_Node'Class) is
+         begin
+            if not Node.Is_Null then
+               declare
+                  Prev : constant Libadalang.Common.Token_Reference :=
+                    Libadalang.Common.Previous (Node.Token_Start, True);
+               begin
+                  Self.Parent.Context.Append_Location
+                    (Result => Self.Response,
+                     Filter => Self.Filter,
+                     Unit   => Node.Unit,
+                     Token  => Prev);
+               end;
+            end if;
+         end Append_Prev_Token_Location;
+
+         Document : constant LSP.Ada_Documents.Document_Access :=
+           Self.Parent.Context.Get_Open_Document (Value.textDocument.uri);
+         Token    : Libadalang.Common.Token_Reference :=
+           Document.Get_Token_At (Context.all, Value.position);
+         Node     : Libadalang.Analysis.Ada_Node;
+         Position : LSP.Structures.Position;
+      begin
+         if Token /= No_Token then
+            if Token.Data.Kind = Ada_Is then
+               Node := Document.Get_Node_At (Context => Context.all, Position => Value.position);
+
+               if not Node.Is_Null and then Node.Kind in Ada_Subp_Body_Range
+               then
+                  --  We are on the 'is' of a subprogram body: retrieve the
+                  --  enclosing subprogram's defining name instead of checking
+                  --  for the previous token's node since it might refer to the
+                  --  subprogram's parameter list.
+                  Definition := Node.As_Subp_Body.P_Defining_Name;
+               else
+                  --  We are on the 'is' of a package, task, or protected type: retrieve
+                  --  the previous token's node, which should be the defining name.
+                  Token := Token.Previous (True);
+
+                  if Token = No_Token then
+                     --  Return if there is no previous token.
+                     return;
+                  end if;
+
+                  Position :=
+                    Document.To_A_Range (Token.Data.Sloc_Range).start;
+                  Node :=
+                    Document.Get_Node_At
+                      (Context => Context.all, Position => Position);
+
+                  Definition := Laltools.Common.Resolve_Name_Precisely (Node.As_Name);
+               end if;
+
+               --  Append private part, begin locations to the response
+               for Part of Definition.P_Basic_Decl.P_All_Parts loop
+                  case Part.Kind is
+
+                     when Libadalang.Common.Ada_Package_Body_Range =>
+                        Append_Prev_Token_Location (Part.As_Package_Body.F_Stmts);
+
+                     when Libadalang.Common.Ada_Subp_Body_Range =>
+                        Append_Prev_Token_Location (Part.As_Subp_Body.F_Stmts);
+
+                     when Libadalang.Common.Ada_Task_Body_Range =>
+                        Append_Prev_Token_Location (Part.As_Task_Body.F_Stmts);
+
+                     when Libadalang.Common.Ada_Base_Package_Decl =>
+                        Append_Prev_Token_Location
+                          (Part.As_Base_Package_Decl.F_Private_Part);
+
+                     when Libadalang.Common.Ada_Protected_Type_Decl_Range =>
+                        Append_Prev_Token_Location
+                          (Part
+                             .As_Protected_Type_Decl
+                             .F_Definition
+                             .F_Private_Part);
+
+                     when Libadalang.Common.Ada_Single_Protected_Decl_Range =>
+                        Append_Prev_Token_Location
+                          (Part
+                             .As_Single_Protected_Decl
+                             .F_Definition
+                             .F_Private_Part);
+
+                     when Libadalang.Common.Ada_Task_Type_Decl_Range =>
+                        Append_Prev_Token_Location
+                          (Part.As_Task_Type_Decl.F_Definition.F_Private_Part);
+
+                     when Libadalang.Common.Ada_Single_Task_Decl_Range =>
+                        Append_Prev_Token_Location
+                          (Part
+                             .As_Single_Task_Decl
+                             .F_Task_Type
+                             .F_Definition
+                             .F_Private_Part);
+
+                     when others =>
+                        null;
+                  end case;
+               end loop;
+            end if;
+         end if;
+      end Retrieve_Alternate_Part_Location;
+
    begin
       if Self.Contexts.Is_Empty then
          --  No more contexts to process, sort and return collected results
@@ -148,6 +275,7 @@ package body LSP.Ada_Definition is
         (Self.Parent.Context.Get_Node_At (Context.all, Value));
 
       if Name_Node.Is_Null then
+         Retrieve_Alternate_Part_Location;
          return;
       end if;
 
diff --git a/source/ada/lsp-ada_handlers-locations.adb b/source/ada/lsp-ada_handlers-locations.adb
@@ -32,9 +32,41 @@ package body LSP.Ada_Handlers.Locations is
         return LSP.Structures.A_Range;
 
    function From_LSP_Range
-     (Unit : Libadalang.Analysis.Analysis_Unit;
-      Sloc : LSP.Structures.A_Range)
-        return Langkit_Support.Slocs.Source_Location_Range;
+     (Unit : Libadalang.Analysis.Analysis_Unit; Sloc : LSP.Structures.A_Range)
+      return Langkit_Support.Slocs.Source_Location_Range;
+
+   ---------------------
+   -- Append_Location --
+   ---------------------
+
+   procedure Append_Location
+     (Self   : in out Message_Handler;
+      Result : in out LSP.Structures.Location_Vector;
+      Filter : in out LSP.Locations.File_Span_Sets.Set;
+      Unit   : Libadalang.Analysis.Analysis_Unit;
+      Token  : Libadalang.Common.Token_Reference)
+   is
+      use type Libadalang.Common.Token_Reference;
+   begin
+      if Token /= Libadalang.Common.No_Token then
+         declare
+            URI : constant LSP.Structures.DocumentUri :=
+              (VSS.Strings.Conversions.To_Virtual_String
+                 (URIs.Conversions.From_File (Unit.Get_Filename))
+                   with null record);
+
+            Value : constant LSP.Structures.Location :=
+              (uri     => URI,
+               a_range => Locations.To_LSP_Range (Self, Unit, Token),
+               alsKind => LSP.Constants.Empty);
+         begin
+            if not Filter.Contains (Value) then
+               Result.Append (Value);
+               Filter.Insert (Value);
+            end if;
+         end;
+      end if;
+   end Append_Location;
 
    ---------------------
    -- Append_Location --
diff --git a/source/ada/lsp-ada_handlers-locations.ads b/source/ada/lsp-ada_handlers-locations.ads
@@ -69,8 +69,15 @@ package LSP.Ada_Handlers.Locations is
       return Libadalang.Analysis.Ada_Node;
 
    function Start_Position
-     (Token : Libadalang.Common.Token_Reference)
-      return LSP.Structures.Position;
+     (Token : Libadalang.Common.Token_Reference) return LSP.Structures.Position;
+
+   procedure Append_Location
+     (Self   : in out Message_Handler;
+      Result : in out LSP.Structures.Location_Vector;
+      Filter : in out LSP.Locations.File_Span_Sets.Set;
+      Unit   : Libadalang.Analysis.Analysis_Unit;
+      Token  : Libadalang.Common.Token_Reference);
+   --  Append the location corresponding to the given token to the Result.
 
    procedure Append_Location
      (Self   : in out Message_Handler;
diff --git a/source/ada/lsp-ada_handlers.adb b/source/ada/lsp-ada_handlers.adb
@@ -197,6 +197,14 @@ package body LSP.Ada_Handlers is
       Kinds  : AlsReferenceKind_Array := LSP.Constants.Empty)
    renames LSP.Ada_Handlers.Locations.Append_Location;
 
+   overriding procedure Append_Location
+     (Self   : in out Message_Handler;
+      Result : in out LSP.Structures.Location_Vector;
+      Filter : in out LSP.Locations.File_Span_Sets.Set;
+      Unit   : Libadalang.Analysis.Analysis_Unit;
+      Token  : Libadalang.Common.Token_Reference)
+        renames LSP.Ada_Handlers.Locations.Append_Location;
+
    function Project_Predefined_Units
      (Self : in out Message_Handler; Context : LSP.Ada_Contexts.Context)
       return Libadalang.Analysis.Analysis_Unit_Array;
diff --git a/source/ada/lsp-ada_handlers.ads b/source/ada/lsp-ada_handlers.ads
@@ -571,6 +571,13 @@ private
       Node   : Libadalang.Analysis.Ada_Node'Class;
       Kinds  : LSP.Structures.AlsReferenceKind_Set := LSP.Constants.Empty);
 
+   overriding procedure Append_Location
+     (Self   : in out Message_Handler;
+      Result : in out LSP.Structures.Location_Vector;
+      Filter : in out LSP.Locations.File_Span_Sets.Set;
+      Unit   : Libadalang.Analysis.Analysis_Unit;
+      Token  : Libadalang.Common.Token_Reference);
+
    overriding procedure Trace_Exception
      (Self    : Message_Handler;
       Error   : Ada.Exceptions.Exception_Occurrence;
diff --git a/source/ada/lsp-ada_job_contexts.ads b/source/ada/lsp-ada_job_contexts.ads
@@ -10,7 +10,7 @@
 -- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
 -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
 -- License for  more details.  You should have  received  a copy of the GNU --
--- General  Public  License  distributed  with  this  software;   see  file --
+-- General  Public  License  distributed  with  this  software;z   see  file --
 -- COPYING3.  If not, go to http://www.gnu.org/licenses for a complete copy --
 -- of the license.                                                          --
 ------------------------------------------------------------------------------
@@ -196,6 +196,15 @@ package LSP.Ada_Job_Contexts is
    --  Append given Node location to the Result.
    --  Do nothing if the item inside of an synthetic file (like __standard).
 
+   procedure Append_Location
+     (Self   : in out Ada_Job_Context;
+      Result : in out LSP.Structures.Location_Vector;
+      Filter : in out LSP.Locations.File_Span_Sets.Set;
+      Unit   : Libadalang.Analysis.Analysis_Unit;
+      Token  : Libadalang.Common.Token_Reference)
+        is abstract;
+   --  Append given token location to the Result.
+
    procedure Trace_Exception
      (Self    : Ada_Job_Context;
       Error   : Ada.Exceptions.Exception_Occurrence;
diff --git a/testsuite/ada_lsp/definition_begin_private/main.adb b/testsuite/ada_lsp/definition_begin_private/main.adb
@@ -0,0 +1,92 @@
+procedure Main is
+   package Pkg is
+      X : Integer;
+   private
+      function Y return Integer;
+   end Pkg;
+
+   package body Pkg is
+      Z : Integer;
+
+      function Y return Integer is
+      begin
+         return (Z);
+      end Y;
+
+   begin
+      Z := 0;
+   end Pkg;
+
+   protected type Pr_Type is
+      procedure Proc;
+   private
+      procedure Priv;
+   end Pr_Type;
+
+   protected body Pr_Type is
+      procedure Proc is
+      begin
+         Priv;
+      end Proc;
+
+      procedure Priv is
+      begin
+         null;
+      end Priv;
+   end Pr_Type;
+
+   protected Pr_Obj is
+      procedure Proc;
+   private
+      procedure Priv;
+   end Pr_Obj;
+
+   protected body Pr_Obj is
+      procedure Proc is
+      begin
+         Priv;
+      end Proc;
+
+      procedure Priv is
+      begin
+         null;
+      end Priv;
+   end Pr_Obj;
+
+   task type Task_Type is
+      pragma Page;
+   private
+      entry Entr;
+   end Task_Type;
+
+   task body Task_Type is
+      X : Integer;
+   begin
+      loop
+         accept Entr;
+      end loop;
+   end Task_Type;
+
+   task Task_Obj is
+      pragma Page;
+   private
+      entry Entr;
+   end Task_Obj;
+
+   task body Task_Obj is
+      X : Integer;
+   begin
+      loop
+         accept Entr;
+      end loop;
+   end Task_Obj;
+
+   procedure Local (A : Integer) is
+      X : Integer;
+   begin
+      X := A;
+   end Local;
+
+begin
+   null;
+end Main;
diff --git a/testsuite/ada_lsp/definition_begin_private/test.json b/testsuite/ada_lsp/definition_begin_private/test.json
diff --git a/testsuite/ada_lsp/definition_begin_private/test.yaml b/testsuite/ada_lsp/definition_begin_private/test.yaml
