From 9524ca676404a48025fd3a4e2bbb6527595fe4e1 Mon Sep 17 00:00:00 2001 From: Maxim Reznik Date: Wed, 10 Apr 2024 15:30:11 +0300 Subject: [PATCH 1/5] Rewrite document symbol request as a job Refs #1141 --- source/ada/lsp-ada_document_symbol.adb | 768 ++++++++++++++++++ source/ada/lsp-ada_document_symbol.ads | 38 + source/ada/lsp-ada_driver.adb | 10 + source/ada/lsp-ada_handlers-symbols.adb | 488 ----------- source/ada/lsp-ada_handlers-symbols.ads | 15 - source/ada/lsp-ada_handlers.adb | 49 +- source/ada/lsp-ada_handlers.ads | 16 +- source/ada/lsp-ada_job_contexts.ads | 10 + .../SA21-029.documentSymbol.with/test.json | 2 +- .../test.json | 8 +- .../UA28-007.Did_Create_Files_0/test.json | 16 +- .../UA28-007.Did_Delete_Files_0/test.json | 14 +- .../UA28-007.Did_Rename_Files_0/test.json | 4 +- 13 files changed, 864 insertions(+), 574 deletions(-) create mode 100644 source/ada/lsp-ada_document_symbol.adb create mode 100644 source/ada/lsp-ada_document_symbol.ads diff --git a/source/ada/lsp-ada_document_symbol.adb b/source/ada/lsp-ada_document_symbol.adb new file mode 100644 index 000000000..b9f17569d --- /dev/null +++ b/source/ada/lsp-ada_document_symbol.adb @@ -0,0 +1,768 @@ +------------------------------------------------------------------------------ +-- Language Server Protocol -- +-- -- +-- Copyright (C) 2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. This software is distributed in the hope that it will be useful, -- +-- 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 -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Wide_Wide_Latin_1; +with Ada.Containers.Doubly_Linked_Lists; +with Ada.Unchecked_Deallocation; + +with GNATCOLL.VFS; + +with Langkit_Support.Text; +with Libadalang.Analysis; +with Libadalang.Common; +with Libadalang.Iterators; + +with VSS.Characters; +with VSS.Strings; + +with LSP.Ada_Context_Sets; +with LSP.Constants; +with LSP.Client_Message_Receivers; +with LSP.Enumerations; +with LSP.Server_Request_Jobs; +with LSP.Server_Requests.DocumentSymbol; +with LSP.Structures; +with LSP.Search; +with LSP.Utils; + +package body LSP.Ada_Document_Symbol is + + type Search_Pattern_Access is access LSP.Search.Search_Pattern'Class; + + procedure Free is new Ada.Unchecked_Deallocation + (LSP.Search.Search_Pattern'Class, Search_Pattern_Access); + + type Traverse_Iterator_Access is access + Libadalang.Iterators.Traverse_Iterator'Class; + + procedure Free is new Ada.Unchecked_Deallocation + (Libadalang.Iterators.Traverse_Iterator'Class, Traverse_Iterator_Access); + + type Flat_Document_Symbol_Job + (Parent : not null access constant Ada_Document_Symbol_Handler) is limited + new LSP.Server_Request_Jobs.Server_Request_Job + (Priority => LSP.Server_Jobs.Low) + with record + Pattern : Search_Pattern_Access; + Cursor : Traverse_Iterator_Access; + Response : LSP.Structures.DocumentSymbol_Result; + end record; + + overriding procedure Execute_Request + (Self : in out Flat_Document_Symbol_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status); + + type Stack_Item is record + Node : Libadalang.Analysis.Ada_Node; + Children : LSP.Structures.DocumentSymbol_Vector; + end record; + + package Stack_Item_Lists is new Ada.Containers.Doubly_Linked_Lists + (Stack_Item); + + type Full_Document_Symbol_Job + (Parent : not null access constant Ada_Document_Symbol_Handler) is limited + new LSP.Server_Request_Jobs.Server_Request_Job + (Priority => LSP.Server_Jobs.Low) + with record + Pattern : Search_Pattern_Access; + Node : Libadalang.Analysis.Ada_Node; + Stack : Stack_Item_Lists.List; + end record; + + overriding procedure Execute_Request + (Self : in out Full_Document_Symbol_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status); + + function "or" + (Left : LSP.Structures.AlsSearchKind_Optional; + Right : LSP.Enumerations.AlsSearchKind) + return LSP.Enumerations.AlsSearchKind is + (if Left.Is_Set then Left.Value else Right); + + function Get_Profile + (Node : Libadalang.Analysis.Basic_Decl) return VSS.Strings.Virtual_String; + + function Is_Function + (Node : Libadalang.Analysis.Basic_Decl) return Boolean; + + function Get_Visibility + (Node : Libadalang.Analysis.Basic_Decl) + return LSP.Structures.AlsVisibility_Optional; + + function Is_Declaration (Node : Libadalang.Analysis.Ada_Node) + return LSP.Structures.Boolean_Optional is + (case Node.Kind is + when Libadalang.Common.Ada_Base_Package_Decl | + Libadalang.Common.Ada_Generic_Package_Decl | + Libadalang.Common.Ada_Generic_Package_Instantiation | + Libadalang.Common.Ada_Generic_Package_Renaming_Decl | + Libadalang.Common.Ada_Package_Renaming_Decl | + Libadalang.Common.Ada_Abstract_Subp_Decl | + Libadalang.Common.Ada_Formal_Subp_Decl | + Libadalang.Common.Ada_Subp_Decl | + Libadalang.Common.Ada_Subp_Renaming_Decl | + Libadalang.Common.Ada_Generic_Subp_Instantiation | + Libadalang.Common.Ada_Generic_Subp_Renaming_Decl | + Libadalang.Common.Ada_Generic_Subp_Decl | + Libadalang.Common.Ada_Null_Subp_Decl | + Libadalang.Common.Ada_Expr_Function | + Libadalang.Common.Ada_Protected_Type_Decl | + Libadalang.Common.Ada_Single_Protected_Decl | + Libadalang.Common.Ada_Entry_Decl | + Libadalang.Common.Ada_Type_Decl | + Libadalang.Common.Ada_Single_Task_Decl | + Libadalang.Common.Ada_Task_Type_Decl => + + (Is_Set => True, Value => True), + + when others => + (Is_Set => True, Value => False)); + + ---------------- + -- Create_Job -- + ---------------- + + overriding function Create_Job + (Self : Ada_Document_Symbol_Handler; + Message : LSP.Server_Messages.Server_Message_Access) + return LSP.Server_Jobs.Server_Job_Access + is + use type LSP.Structures.Boolean_Optional; + + Value : LSP.Structures.DocumentSymbolParams + renames LSP.Server_Requests.DocumentSymbol.Request + (Message.all).Params; + + File : constant GNATCOLL.VFS.Virtual_File := + Self.Context.To_File (Value.textDocument.uri); + + Context : constant LSP.Ada_Context_Sets.Context_Access := + Self.Context.Get_Best_Context (Value.textDocument.uri); + + Unit : constant Libadalang.Analysis.Analysis_Unit := + Context.Get_AU (File); + + Is_Defining_Name : constant Libadalang.Iterators.Ada_Node_Predicate := + Libadalang.Iterators.Kind_Is (Libadalang.Common.Ada_Defining_Name); + -- This object will be deallocated by Cursor's finalization + + function Flat_Job return LSP.Server_Jobs.Server_Job_Access is + (new Flat_Document_Symbol_Job' + (Parent => Self'Unchecked_Access, + Request => LSP.Server_Request_Jobs.Request_Access (Message), + Cursor => new Libadalang.Iterators.Traverse_Iterator'Class' + (Libadalang.Iterators.Find (Unit.Root, Is_Defining_Name)), + Pattern => new LSP.Search.Search_Pattern'Class' + (LSP.Search.Build + (Pattern => Value.query, + Case_Sensitive => Value.case_sensitive = LSP.Constants.True, + Whole_Word => Value.whole_word = LSP.Constants.True, + Negate => Value.negate = LSP.Constants.True, + Kind => Value.kind + or LSP.Enumerations.Start_Word_Text)), + Response => <>)); + + function Full_Job return LSP.Server_Jobs.Server_Job_Access is + (new Full_Document_Symbol_Job' + (Parent => Self'Unchecked_Access, + Request => LSP.Server_Request_Jobs.Request_Access (Message), + Node => Unit.Root, + Stack => [(Node => Libadalang.Analysis.No_Ada_Node, + Children => <>)], + Pattern => new LSP.Search.Search_Pattern'Class' + (LSP.Search.Build + (Pattern => Value.query, + Case_Sensitive => Value.case_sensitive = LSP.Constants.True, + Whole_Word => Value.whole_word = LSP.Constants.True, + Negate => Value.negate = LSP.Constants.True, + Kind => Value.kind + or LSP.Enumerations.Start_Word_Text)))); + begin + if Self.Context.Client.Hierarchical_Symbol then + return Full_Job; + else + return Flat_Job; + end if; + end Create_Job; + + --------------------- + -- Execute_Request -- + --------------------- + + overriding procedure Execute_Request + (Self : in out Flat_Document_Symbol_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status) + is + Message : LSP.Server_Requests.DocumentSymbol.Request + renames LSP.Server_Requests.DocumentSymbol.Request (Self.Message.all); + + Element : Libadalang.Analysis.Ada_Node; + begin + if Self.Cursor.Next (Element) then + declare + use type LSP.Enumerations.SymbolKind; + + Item : LSP.Structures.SymbolInformation; + Kind : constant LSP.Enumerations.SymbolKind := + LSP.Utils.Get_Decl_Kind + (Element.As_Defining_Name.P_Basic_Decl, Ignore_Local => True); + begin + if Kind /= LSP.Enumerations.A_Null + and then Self.Pattern.Match + (VSS.Strings.To_Virtual_String (Element.Text)) + then + Item := + (name => + VSS.Strings.To_Virtual_String (Element.Text), + kind => Kind, + tags => LSP.Constants.Empty, + deprecated => <>, + location => + Self.Parent.Context.To_LSP_Location (Element), + containerName => <>); + + Self.Response.Variant_1.Append (Item); + end if; + + Status := LSP.Server_Jobs.Continue; + end; + else + Client.On_DocumentSymbol_Response (Message.Id, Self.Response); + + Free (Self.Pattern); + Free (Self.Cursor); + Status := LSP.Server_Jobs.Done; + end if; + end Execute_Request; + + --------------------- + -- Execute_Request -- + --------------------- + + overriding procedure Execute_Request + (Self : in out Full_Document_Symbol_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status) + is + use type Ada.Containers.Count_Type; + + function Is_Leaf_Symbol + (Node : Libadalang.Analysis.Ada_Node) return Boolean; + -- Node has a symbol and can't contain nested symbols. + -- Also return True for uninteresting symbols to avoid + -- descend under their subtrees + + function Is_Namespace_Symbol + (Node : Libadalang.Analysis.Ada_Node) return Boolean; + -- Node has a symbol and may contain nested symbols + + procedure Skip_Node (Node : in out Libadalang.Analysis.Ada_Node); + -- If we are leaving the node at top of the stack, then append + -- namespace symbol to the next stack element. + -- Go to node sibling if any or skip the its parent otherwise. + + procedure Continue (Node : in out Libadalang.Analysis.Ada_Node); + -- Set Node to Node.First_Child if any, do Skip_Node (Node) otherwise + + procedure Append_Leaf_Symbol (Node : Libadalang.Analysis.Ada_Node); + procedure Append_Namespace_Symbol + (Node : Libadalang.Analysis.Ada_Node; + Children : in out LSP.Structures.DocumentSymbol_Vector); + + ------------------------ + -- Append_Leaf_Symbol -- + ------------------------ + + procedure Append_Leaf_Symbol (Node : Libadalang.Analysis.Ada_Node) is + + procedure Append_Name + (Name : Libadalang.Analysis.Name'Class; + Kind : LSP.Enumerations.SymbolKind; + Detail : VSS.Strings.Virtual_String := + VSS.Strings.Empty_Virtual_String); + + procedure Append_Name + (Name : Libadalang.Analysis.Name'Class; + Kind : LSP.Enumerations.SymbolKind; + Detail : VSS.Strings.Virtual_String := + VSS.Strings.Empty_Virtual_String) + is + Node_Span : constant LSP.Structures.A_Range := + Self.Parent.Context.To_LSP_Location (Node).a_range; + + Name_Span : constant LSP.Structures.A_Range := + Self.Parent.Context.To_LSP_Location (Name).a_range; + + Top : Stack_Item renames Self.Stack (Self.Stack.Last); + + Item : constant LSP.Structures.DocumentSymbol := + (name => VSS.Strings.To_Virtual_String (Name.Text), + detail => Detail, + kind => Kind, + a_range => Node_Span, + selectionRange => Name_Span, + others => <>); + begin + Top.Children.Append (Item); + end Append_Name; + + begin + case Node.Kind is + when Libadalang.Common.Ada_With_Clause_Range => + for Name of Node.As_With_Clause.F_Packages loop + Append_Name (Name, LSP.Enumerations.Namespace); + end loop; + + when Libadalang.Common.Ada_Pragma_Node => + if Self.Stack.Length < 3 then + Append_Name + (Node.As_Pragma_Node.F_Id, + Kind => LSP.Enumerations.Property, + Detail => VSS.Strings.To_Virtual_String + ("(" & Node.As_Pragma_Node.F_Args.Text & ")")); + end if; + + when others => + null; -- Ignore other nodes filtered by Is_Leaf_Symbol + end case; + end Append_Leaf_Symbol; + + ----------------------------- + -- Append_Namespace_Symbol -- + ----------------------------- + + procedure Append_Namespace_Symbol + (Node : Libadalang.Analysis.Ada_Node; + Children : in out LSP.Structures.DocumentSymbol_Vector) + is + procedure Append_Name + (Name : Libadalang.Analysis.Ada_Node'Class; + Text : VSS.Strings.Virtual_String; + Kind : LSP.Enumerations.SymbolKind; + Is_Proc : LSP.Structures.Boolean_Optional := (Is_Set => False); + Visible : LSP.Structures.AlsVisibility_Optional := + (Is_Set => False); + Detail : VSS.Strings.Virtual_String := + VSS.Strings.Empty_Virtual_String); + + procedure Append_Name + (Name : Libadalang.Analysis.Ada_Node'Class; + Text : VSS.Strings.Virtual_String; + Kind : LSP.Enumerations.SymbolKind; + Is_Proc : LSP.Structures.Boolean_Optional := (Is_Set => False); + Visible : LSP.Structures.AlsVisibility_Optional := + (Is_Set => False); + Detail : VSS.Strings.Virtual_String := + VSS.Strings.Empty_Virtual_String) + is + Node_Span : constant LSP.Structures.A_Range := + Self.Parent.Context.To_LSP_Location (Node).a_range; + + Name_Span : constant LSP.Structures.A_Range := + Self.Parent.Context.To_LSP_Location (Name).a_range; + + Top : Stack_Item renames Self.Stack (Self.Stack.Last); + + Item : constant LSP.Structures.DocumentSymbol := + (name => Text, + detail => Detail, + kind => Kind, + a_range => Node_Span, + selectionRange => Name_Span, + children => Children, + alsIsDeclaration => Is_Declaration (Node), + alsIsAdaProcedure => Is_Proc, + alsVisibility => Visible, + others => <>); + begin + if Self.Pattern.Match (Text) then + Top.Children.Append (Item); + end if; + end Append_Name; + + begin + case Node.Kind is + when Libadalang.Common.Ada_Ada_Node_List_Range => + Append_Name + (Name => Node.As_Ada_Node_List.Last_Child, + Text => "With clauses", + Kind => LSP.Enumerations.Namespace); + + when Libadalang.Common.Ada_Basic_Decl => + for Name of Node.As_Basic_Decl.P_Defining_Names loop + Append_Name + (Name => Name, + Text => VSS.Strings.To_Virtual_String (Name.Text), + Kind => LSP.Utils.Get_Decl_Kind + (Node.As_Basic_Decl, + Ignore_Local => Self.Stack.Length > 2), + Is_Proc => (if Is_Function (Node.As_Basic_Decl) + then (Is_Set => False) + else (Is_Set => True, Value => True)), + Visible => Get_Visibility (Node.As_Basic_Decl), + Detail => Get_Profile (Node.As_Basic_Decl)); + end loop; + + when others => + null; -- Unexpected + end case; + end Append_Namespace_Symbol; + + -------------------- + -- Is_Leaf_Symbol -- + -------------------- + + function Is_Leaf_Symbol + (Node : Libadalang.Analysis.Ada_Node) return Boolean is + begin + case Node.Kind is + when Libadalang.Common.Ada_With_Clause_Range => + return True; + when Libadalang.Common.Ada_Pragma_Node => + return True; + when Libadalang.Common.Ada_Basic_Decl => + declare + use type LSP.Enumerations.SymbolKind; + + Decl : constant Libadalang.Analysis.Basic_Decl := + Node.As_Basic_Decl; + + Kind : constant LSP.Enumerations.SymbolKind := + LSP.Utils.Get_Decl_Kind + (Decl, Ignore_Local => Self.Stack.Length > 2); + begin + return Kind = LSP.Enumerations.A_Null; + end; + + when others => + return False; + end case; + end Is_Leaf_Symbol; + + ------------------------- + -- Is_Namespace_Symbol -- + ------------------------- + + function Is_Namespace_Symbol + (Node : Libadalang.Analysis.Ada_Node) return Boolean is + begin + case Node.Kind is + when Libadalang.Common.Ada_Ada_Node_List_Range => + -- An artifical "With clauses" node + return Self.Stack.Length < 2 + and then Node.As_Ada_Node_List.Ada_Node_List_Has_Element (1); + + when Libadalang.Common.Ada_Basic_Decl => + return True; + + when others => + return False; + end case; + end Is_Namespace_Symbol; + + --------------- + -- Skip_Node -- + --------------- + + procedure Skip_Node (Node : in out Libadalang.Analysis.Ada_Node) is + use type Libadalang.Analysis.Ada_Node; + + function Next_Sibling return Libadalang.Analysis.Ada_Node; + + Parent : constant Libadalang.Analysis.Ada_Node := Node.Parent; + + ------------------ + -- Next_Sibling -- + ------------------ + + function Next_Sibling return Libadalang.Analysis.Ada_Node is + Index : constant Positive := Node.Child_Index + 1; + -- Turn 0-based Child_Index into 1-based child index + Result : Libadalang.Analysis.Ada_Node; + begin + for J in Index + 1 .. Parent.Children_Count loop + Result := Parent.Child (J); + + exit when not Result.Is_Null; + end loop; + + return Result; + end Next_Sibling; + + Sibling : constant Libadalang.Analysis.Ada_Node := + (if Parent.Is_Null then Parent else Next_Sibling); + begin + -- We are leaving Node, so check if it is on the top os the stack + if Self.Stack.Last_Element.Node = Node then + declare + Children : LSP.Structures.DocumentSymbol_Vector := + Self.Stack (Self.Stack.Last).Children; + begin + Self.Stack.Delete_Last; + Append_Namespace_Symbol (Node, Children); + end; + end if; + + if Sibling.Is_Null then + Node := Parent; + + if not Parent.Is_Null then + Skip_Node (Node); + end if; + else + Node := Sibling; + end if; + end Skip_Node; + + -------------- + -- Continue -- + -------------- + + procedure Continue (Node : in out Libadalang.Analysis.Ada_Node) is + Next : constant Libadalang.Analysis.Ada_Node := Self.Node.First_Child; + begin + if Next.Is_Null then + Skip_Node (Node); + else + Node := Next; + end if; + end Continue; + + Message : LSP.Server_Requests.DocumentSymbol.Request + renames LSP.Server_Requests.DocumentSymbol.Request (Self.Message.all); + + begin + Status := LSP.Server_Jobs.Continue; + + while not Self.Node.Is_Null loop + if Is_Leaf_Symbol (Self.Node) then + Append_Leaf_Symbol (Self.Node); + Skip_Node (Self.Node); + + exit; + + elsif Is_Namespace_Symbol (Self.Node) then + Self.Stack.Append ((Node => Self.Node, Children => <>)); + Continue (Self.Node); + + else + Continue (Self.Node); + end if; + end loop; + + if Self.Node.Is_Null then + Free (Self.Pattern); + Client.On_DocumentSymbol_Response + (Message.Id, + (Kind => LSP.Structures.Variant_2, + Variant_2 => Self.Stack.Last_Element.Children)); + Status := LSP.Server_Jobs.Done; + end if; + end Execute_Request; + + ----------------- + -- Get_Profile -- + ----------------- + + function Get_Profile + (Node : Libadalang.Analysis.Basic_Decl) return VSS.Strings.Virtual_String + is + use Libadalang.Analysis; + use Libadalang.Common; + + function To_Text + (Node : Ada_Node'Class) return VSS.Strings.Virtual_String; + -- Retrieve the node text and format it + + function To_Profile + (Node : Libadalang.Analysis.Subp_Spec'Class) + return VSS.Strings.Virtual_String; + + ------------- + -- To_Text -- + ------------- + + function To_Text + (Node : Ada_Node'Class) return VSS.Strings.Virtual_String + is + Node_Text : constant Langkit_Support.Text.Text_Type := Node.Text; + Was_Space : Boolean := False; + Result : VSS.Strings.Virtual_String; + begin + for I in Node_Text'Range loop + if Node_Text (I) = ' ' then + -- Trim multiple whitespace to only keep one + + if not Was_Space then + Result.Append + (VSS.Characters.Virtual_Character (Node_Text (I))); + end if; + + Was_Space := True; + + -- Remove the new line character + + elsif Node_Text (I) /= Ada.Characters.Wide_Wide_Latin_1.LF then + Was_Space := False; + Result.Append + (VSS.Characters.Virtual_Character (Node_Text (I))); + end if; + end loop; + + return Result; + end To_Text; + + ---------------- + -- To_Profile -- + ---------------- + + function To_Profile + (Node : Libadalang.Analysis.Subp_Spec'Class) + return VSS.Strings.Virtual_String + is + Result : VSS.Strings.Virtual_String; + Params : constant Param_Spec_Array := Node.P_Params; + Returns : constant Type_Expr := Node.F_Subp_Returns; + + begin + if Params'Length > 0 then + Result.Append ('('); + end if; + + for Param of Params loop + declare + use type VSS.Strings.Character_Count; + + Names : constant Defining_Name_List := Param.F_Ids; + Init : constant Expr := Param.F_Default_Expr; + Item : VSS.Strings.Virtual_String; + Mode : constant Ada_Mode := Param.F_Mode; + + begin + Item.Append (" :"); + + case Mode is + when Ada_Mode_Default | Ada_Mode_In => + Item.Append (" in "); + when Ada_Mode_In_Out => + Item.Append (" in out "); + when Ada_Mode_Out => + Item.Append (" out "); + end case; + + Item.Append (To_Text (Param.F_Type_Expr)); + + if not Init.Is_Null then + Item.Append (" := "); + Item.Append (To_Text (Init)); + end if; + + for J in Names.First_Child_Index .. Names.Last_Child_Index loop + if Result.Character_Length /= 1 then + Result.Append ("; "); + end if; + + Result.Append (To_Text (Names.Child (J))); + Result.Append (Item); + end loop; + end; + end loop; + + if Params'Length > 0 then + Result.Append (')'); + end if; + + if not Returns.Is_Null then + Result.Append (" return "); + Result.Append (To_Text (Returns)); + end if; + + return Result; + end To_Profile; + + begin + case Node.Kind is + when Ada_Classic_Subp_Decl => + return To_Profile (Node.As_Classic_Subp_Decl.F_Subp_Spec); + when Ada_Base_Subp_Body => + return To_Profile (Node.As_Base_Subp_Body.F_Subp_Spec); + when Ada_Generic_Subp_Decl => + return To_Profile + (Node.As_Generic_Subp_Decl.F_Subp_Decl.F_Subp_Spec); + when others => + return VSS.Strings.Empty_Virtual_String; + end case; + end Get_Profile; + + -------------------- + -- Get_Visibility -- + -------------------- + + function Get_Visibility + (Node : Libadalang.Analysis.Basic_Decl) + return LSP.Structures.AlsVisibility_Optional + is + use Libadalang.Common; + begin + for Parent of Node.Parents loop + if Parent.Kind = Ada_Private_Part then + return (True, LSP.Enumerations.Als_Private); + elsif Parent.Kind in Ada_Protected_Body | Ada_Protected_Def then + return (True, LSP.Enumerations.Als_Protected); + end if; + end loop; + return (True, LSP.Enumerations.Als_Public); + end Get_Visibility; + + ----------------- + -- Is_Function -- + ----------------- + + function Is_Function + (Node : Libadalang.Analysis.Basic_Decl) return Boolean + is + + function Has_Returns + (Node : Libadalang.Analysis.Subp_Spec'Class) + return Boolean is (not Node.F_Subp_Returns.Is_Null); + + begin + case Node.Kind is + when Libadalang.Common.Ada_Classic_Subp_Decl => + return Has_Returns (Node.As_Classic_Subp_Decl.F_Subp_Spec); + + when Libadalang.Common.Ada_Base_Subp_Body => + return Has_Returns (Node.As_Base_Subp_Body.F_Subp_Spec); + + when Libadalang.Common.Ada_Generic_Subp_Decl => + return Has_Returns + (Node.As_Generic_Subp_Decl.F_Subp_Decl.F_Subp_Spec); + + when others => + return False; + end case; + end Is_Function; + +end LSP.Ada_Document_Symbol; diff --git a/source/ada/lsp-ada_document_symbol.ads b/source/ada/lsp-ada_document_symbol.ads new file mode 100644 index 000000000..ef638341b --- /dev/null +++ b/source/ada/lsp-ada_document_symbol.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- Language Server Protocol -- +-- -- +-- Copyright (C) 2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. This software is distributed in the hope that it will be useful, -- +-- 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 -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +------------------------------------------------------------------------------ + +-- This package provides handler and job types for textDocument/documentSymbol +-- requests. + +with LSP.Ada_Job_Contexts; +with LSP.Server_Jobs; +with LSP.Server_Message_Handlers; +with LSP.Server_Messages; + +package LSP.Ada_Document_Symbol is + + type Ada_Document_Symbol_Handler + (Context : not null access LSP.Ada_Job_Contexts.Ada_Job_Context'Class) is + limited new LSP.Server_Message_Handlers.Server_Message_Handler + with null record; + + overriding function Create_Job + (Self : Ada_Document_Symbol_Handler; + Message : LSP.Server_Messages.Server_Message_Access) + return LSP.Server_Jobs.Server_Job_Access; + +end LSP.Ada_Document_Symbol; diff --git a/source/ada/lsp-ada_driver.adb b/source/ada/lsp-ada_driver.adb index 2a68bde92..d9c4194d8 100644 --- a/source/ada/lsp-ada_driver.adb +++ b/source/ada/lsp-ada_driver.adb @@ -40,6 +40,7 @@ with GNATCOLL.Utils; with LSP.Ada_Commands; with LSP.Ada_Definition; with LSP.Ada_Declaration; +with LSP.Ada_Document_Symbol; with LSP.Ada_Did_Change_Configurations; with LSP.Ada_Did_Change_Document; with LSP.Ada_Hover; @@ -80,6 +81,7 @@ with LSP.Server_Notifications.DidChange; with LSP.Server_Notifications.DidChangeConfiguration; with LSP.Server_Requests.Definition; with LSP.Server_Requests.Declaration; +with LSP.Server_Requests.DocumentSymbol; with LSP.Server_Requests.Hover; with LSP.Server_Requests.References; with LSP.Servers; @@ -201,6 +203,10 @@ procedure LSP.Ada_Driver is LSP.Ada_Declaration.Ada_Declaration_Handler (Ada_Handler'Unchecked_Access); + Ada_Document_Symbol_Handler : aliased + LSP.Ada_Document_Symbol.Ada_Document_Symbol_Handler + (Ada_Handler'Unchecked_Access); + GPR_Did_Change_Doc_Handler : aliased LSP.GPR_Did_Change_Document.GPR_Did_Change_Handler (GPR_Handler'Unchecked_Access); @@ -421,6 +427,10 @@ begin (LSP.Server_Requests.Declaration.Request'Tag, Ada_Declaration_Handler'Unchecked_Access); + Server.Register_Handler + (LSP.Server_Requests.DocumentSymbol.Request'Tag, + Ada_Document_Symbol_Handler'Unchecked_Access); + Server.Register_Handler (LSP.Server_Requests.References.Request'Tag, Ada_References_Handler'Unchecked_Access); diff --git a/source/ada/lsp-ada_handlers-symbols.adb b/source/ada/lsp-ada_handlers-symbols.adb index 33c1e129c..5481fbb64 100644 --- a/source/ada/lsp-ada_handlers-symbols.adb +++ b/source/ada/lsp-ada_handlers-symbols.adb @@ -15,502 +15,14 @@ -- of the license. -- ------------------------------------------------------------------------------ -with Ada.Characters.Wide_Wide_Latin_1; - -with Langkit_Support.Text; - with Libadalang.Common; -with Libadalang.Iterators; - -with VSS.Characters; with LSP.Ada_Handlers.Locations; with LSP.Constants; -with LSP.Enumerations; with LSP.Utils; package body LSP.Ada_Handlers.Symbols is - function Get_Profile - (Node : Libadalang.Analysis.Basic_Decl; - Is_Function : out Boolean) - return VSS.Strings.Virtual_String; - -- Return the profile of Node. - - function Is_Declaration (Node : Libadalang.Analysis.Basic_Decl) - return LSP.Structures.Boolean_Optional; - - function Get_Visibility - (Node : Libadalang.Analysis.Basic_Decl) - return LSP.Structures.AlsVisibility_Optional; - - --------------------------- - -- Flat_Document_Symbols -- - --------------------------- - - procedure Flat_Document_Symbols - (Self : in out Message_Handler'Class; - Unit : Libadalang.Analysis.Analysis_Unit; - Pattern : LSP.Search.Search_Pattern'Class; - Result : in out LSP.Structures.DocumentSymbol_Result) - is - Element : Libadalang.Analysis.Ada_Node; - - Is_Defining_Name : constant Libadalang.Iterators.Ada_Node_Predicate := - Libadalang.Iterators.Kind_Is (Libadalang.Common.Ada_Defining_Name); - -- This object will be deallocated by Cursor's finalization - - Cursor : Libadalang.Iterators.Traverse_Iterator'Class := - Libadalang.Iterators.Find (Unit.Root, Is_Defining_Name); - - begin - while not Self.Is_Canceled.all - and then Cursor.Next (Element) - loop - declare - use type LSP.Enumerations.SymbolKind; - - Item : LSP.Structures.SymbolInformation; - Kind : constant LSP.Enumerations.SymbolKind := - LSP.Utils.Get_Decl_Kind - (Element.As_Defining_Name.P_Basic_Decl, Ignore_Local => True); - begin - if Kind /= LSP.Enumerations.A_Null - and then Pattern.Match - (VSS.Strings.To_Virtual_String (Element.Text)) - then - Item := - (name => - VSS.Strings.To_Virtual_String (Element.Text), - kind => Kind, - tags => LSP.Constants.Empty, - deprecated => <>, - location => - LSP.Ada_Handlers.Locations.To_LSP_Location (Self, Element), - containerName => <>); - - Result.Variant_1.Append (Item); - end if; - end; - end loop; - end Flat_Document_Symbols; - - ----------------- - -- Get_Profile -- - ----------------- - - function Get_Profile - (Node : Libadalang.Analysis.Basic_Decl; - Is_Function : out Boolean) return VSS.Strings.Virtual_String - is - use Libadalang.Analysis; - use Libadalang.Common; - - function To_Text - (Node : Ada_Node'Class) return VSS.Strings.Virtual_String; - -- Retrieve the node text and format it - - function To_Profile - (Node : Libadalang.Analysis.Subp_Spec'Class) - return VSS.Strings.Virtual_String; - - ------------- - -- To_Text -- - ------------- - - function To_Text - (Node : Ada_Node'Class) return VSS.Strings.Virtual_String - is - Node_Text : constant Langkit_Support.Text.Text_Type := Node.Text; - Was_Space : Boolean := False; - Result : VSS.Strings.Virtual_String; - begin - for I in Node_Text'Range loop - if Node_Text (I) = ' ' then - -- Trim multiple whitespace to only keep one - - if not Was_Space then - Result.Append - (VSS.Characters.Virtual_Character (Node_Text (I))); - end if; - - Was_Space := True; - - -- Remove the new line character - - elsif Node_Text (I) /= Ada.Characters.Wide_Wide_Latin_1.LF then - Was_Space := False; - Result.Append - (VSS.Characters.Virtual_Character (Node_Text (I))); - end if; - end loop; - - return Result; - end To_Text; - - ---------------- - -- To_Profile -- - ---------------- - - function To_Profile - (Node : Libadalang.Analysis.Subp_Spec'Class) - return VSS.Strings.Virtual_String - is - Result : VSS.Strings.Virtual_String; - Params : constant Param_Spec_Array := Node.P_Params; - Returns : constant Type_Expr := Node.F_Subp_Returns; - - begin - if Params'Length > 0 then - Result.Append ('('); - end if; - - for Param of Params loop - declare - use type VSS.Strings.Character_Count; - - Names : constant Defining_Name_List := Param.F_Ids; - Init : constant Expr := Param.F_Default_Expr; - Item : VSS.Strings.Virtual_String; - Mode : constant Ada_Mode := Param.F_Mode; - - begin - Item.Append (" :"); - - case Mode is - when Ada_Mode_Default | Ada_Mode_In => - Item.Append (" in "); - when Ada_Mode_In_Out => - Item.Append (" in out "); - when Ada_Mode_Out => - Item.Append (" out "); - end case; - - Item.Append (To_Text (Param.F_Type_Expr)); - - if not Init.Is_Null then - Item.Append (" := "); - Item.Append (To_Text (Init)); - end if; - - for J in Names.First_Child_Index .. Names.Last_Child_Index loop - if Result.Character_Length /= 1 then - Result.Append ("; "); - end if; - - Result.Append (To_Text (Names.Child (J))); - Result.Append (Item); - end loop; - end; - end loop; - - if Params'Length > 0 then - Result.Append (')'); - end if; - - if not Returns.Is_Null then - Is_Function := True; - Result.Append (" return "); - Result.Append (To_Text (Returns)); - end if; - - return Result; - end To_Profile; - - begin - Is_Function := False; - - case Node.Kind is - when Ada_Classic_Subp_Decl => - return To_Profile (Node.As_Classic_Subp_Decl.F_Subp_Spec); - when Ada_Base_Subp_Body => - return To_Profile (Node.As_Base_Subp_Body.F_Subp_Spec); - when Ada_Generic_Subp_Decl => - return To_Profile - (Node.As_Generic_Subp_Decl.F_Subp_Decl.F_Subp_Spec); - when others => - return VSS.Strings.Empty_Virtual_String; - end case; - end Get_Profile; - - -------------------- - -- Get_Visibility -- - -------------------- - - function Get_Visibility - (Node : Libadalang.Analysis.Basic_Decl) - return LSP.Structures.AlsVisibility_Optional - is - use Libadalang.Common; - begin - for Parent of Node.Parents loop - if Parent.Kind = Ada_Private_Part then - return (True, LSP.Enumerations.Als_Private); - elsif Parent.Kind in Ada_Protected_Body | Ada_Protected_Def then - return (True, LSP.Enumerations.Als_Protected); - end if; - end loop; - return (True, LSP.Enumerations.Als_Public); - end Get_Visibility; - - ----------------------------------- - -- Hierarchical_Document_Symbols -- - ----------------------------------- - - procedure Hierarchical_Document_Symbols - (Self : in out Message_Handler'Class; - Unit : Libadalang.Analysis.Analysis_Unit; - Pattern : LSP.Search.Search_Pattern'Class; - Result : in out LSP.Structures.DocumentSymbol_Vector) - is - use all type LSP.Enumerations.SymbolKind; - - Empty : LSP.Structures.DocumentSymbol_Vector; - - procedure Walk - (Node : Libadalang.Analysis.Ada_Node; - Nested_Level : Integer; - Vector : in out LSP.Structures.DocumentSymbol_Vector); - -- Traverse Node and all its children recursively. Find any defining - -- name and construct corresponding symbol node, then append it to - -- the Tree under a position pointed by the Cursor. - - ---------- - -- Walk -- - ---------- - - procedure Walk - (Node : Libadalang.Analysis.Ada_Node; - Nested_Level : Integer; - Vector : in out LSP.Structures.DocumentSymbol_Vector) - is - use Libadalang.Analysis; - - Children : LSP.Structures.DocumentSymbol_Vector; - Next_Level : Integer := Nested_Level; - begin - if Node.Is_Null - or else Node.Kind in Libadalang.Common.Ada_Expr - or else Self.Is_Canceled.all - then - return; - - end if; - - Next_Level := Next_Level + - (if Node.Kind in Libadalang.Common.Ada_Basic_Decl then 1 else 0); - - for Child of Node.Children loop - if not Child.Is_Null then - Walk - (Node => Child, - Nested_Level => Next_Level, - Vector => Children); - exit when Self.Is_Canceled.all; - end if; - end loop; - - case Node.Kind is - when Libadalang.Common.Ada_Ada_Node_List_Range => - - -- Check if we are dealing with a list of with-clauses nodes - -- ('namespace' symbol kind). If yes, create a 'fake' parent - -- item called 'With clauses' and put every with-clause within it. - if Children.Length > 0 then - declare - First_Item : constant LSP.Structures.DocumentSymbol := - LSP.Structures.Get_DocumentSymbol_Constant_Reference - (Children, 1); - Package_Deps_Item : LSP.Structures.DocumentSymbol; - begin - if First_Item.kind = Namespace then - declare - Last_Item : constant LSP.Structures.DocumentSymbol := - LSP.Structures.Get_DocumentSymbol_Constant_Reference - (Children, Children.Length); - With_Range : constant LSP.Structures.A_Range := - (First_Item.a_range.start, Last_Item.a_range.an_end); - With_Selection : constant LSP.Structures.A_Range := - (First_Item.a_range.start, - (First_Item.a_range.start.line, - First_Item.a_range.start.character + 4)); - begin - Package_Deps_Item := - (name => - VSS.Strings.To_Virtual_String ("With clauses"), - detail => - VSS.Strings.Empty_Virtual_String, - kind => Namespace, - deprecated => (Is_Set => False), - tags => LSP.Constants.Empty, - a_range => With_Range, - selectionRange => With_Selection, - children => Children, - others => <>); - Vector.Append (Package_Deps_Item); - end; - else - for J in 1 .. Children.Length loop - Vector.Append (Children (J)); - end loop; - end if; - end; - end if; - when Libadalang.Common.Ada_Basic_Decl => - declare - Decl : constant Libadalang.Analysis.Basic_Decl := - Node.As_Basic_Decl; - - Kind : constant LSP.Enumerations.SymbolKind := - LSP.Utils.Get_Decl_Kind - (Decl, Ignore_Local => Nested_Level > 1); - - begin - if Kind /= LSP.Enumerations.A_Null then - declare - Names : constant Libadalang.Analysis.Defining_Name_Array - := Decl.P_Defining_Names; - begin - - for Name of Names loop - exit when Name = Libadalang.Analysis.No_Defining_Name; - - if Pattern.Match - (VSS.Strings.To_Virtual_String (Name.Text)) - then - declare - Is_Function : Boolean; - Profile : constant VSS.Strings.Virtual_String := - Get_Profile (Decl, Is_Function); - Item : constant LSP.Structures.DocumentSymbol := - (name => - VSS.Strings.To_Virtual_String (Name.Text), - detail => Profile, - kind => Kind, - deprecated => (Is_Set => False), - tags => LSP.Constants.Empty, - a_range => Locations.To_LSP_Location - (Self, Node).a_range, - selectionRange => Locations.To_LSP_Location - (Self, Name).a_range, - children => Children, - alsIsDeclaration => Is_Declaration (Decl), - alsIsAdaProcedure => - (if Is_Function then (Is_Set => False) - else (True, True)), - alsVisibility => Get_Visibility (Decl)); - begin - Vector.Append (Item); - end; - end if; - end loop; - end; - end if; - end; - - when Libadalang.Common.Ada_With_Clause_Range => - declare - With_Node : constant Libadalang.Analysis.With_Clause := - Node.As_With_Clause; - begin - for Name of With_Node.F_Packages loop - declare - Item : constant LSP.Structures.DocumentSymbol := - (name => - VSS.Strings.To_Virtual_String (Name.Text), - detail => VSS.Strings.Empty_Virtual_String, - kind => Namespace, - deprecated => (Is_Set => False), - tags => LSP.Constants.Empty, - a_range => Locations.To_LSP_Location - (Self, Node).a_range, - selectionRange => Locations.To_LSP_Location - (Self, Name).a_range, - children => Empty, - others => <>); - begin - Vector.Append (Item); - end; - end loop; - end; - - when Libadalang.Common.Ada_Pragma_Node => - declare - Pragma_Node : constant Libadalang.Analysis.Pragma_Node := - Node.As_Pragma_Node; - Name : constant Libadalang.Analysis.Identifier := - Pragma_Node.F_Id; - Item : constant LSP.Structures.DocumentSymbol := - (name => - VSS.Strings.To_Virtual_String (Name.Text), - detail => - VSS.Strings.To_Virtual_String - ("(" & (Pragma_Node.F_Args.Text & ")")), - kind => Property, - deprecated => (Is_Set => False), - tags => LSP.Constants.Empty, - a_range => Locations.To_LSP_Location - (Self, Node).a_range, - selectionRange => Locations.To_LSP_Location - (Self, Name).a_range, - children => Empty, - others => <>); - begin - if Nested_Level <= 1 then - Vector.Append (Item); - end if; - end; - - when others => - for J in 1 .. Children.Length loop - Vector.Append (Children (J)); - end loop; - end case; - end Walk; - - Root : constant Libadalang.Analysis.Ada_Node := Unit.Root; - begin - Walk (Root, 0, Result); - end Hierarchical_Document_Symbols; - - -------------------- - -- Is_Declaration -- - -------------------- - - function Is_Declaration (Node : Libadalang.Analysis.Basic_Decl) - return LSP.Structures.Boolean_Optional - is - use Libadalang.Common; - begin - return - (case Node.Kind is - when Ada_Base_Package_Decl | - Ada_Generic_Package_Decl | - Ada_Generic_Package_Instantiation | - Ada_Generic_Package_Renaming_Decl | - Ada_Package_Renaming_Decl | - Ada_Abstract_Subp_Decl | - Ada_Formal_Subp_Decl | - Ada_Subp_Decl | - Ada_Subp_Renaming_Decl | - Ada_Generic_Subp_Instantiation | - Ada_Generic_Subp_Renaming_Decl | - Ada_Generic_Subp_Decl | - Ada_Null_Subp_Decl | - Ada_Expr_Function | - Ada_Protected_Type_Decl | - Ada_Single_Protected_Decl | - Ada_Entry_Decl | - Ada_Type_Decl | - Ada_Single_Task_Decl | - Ada_Task_Type_Decl => - - (Is_Set => True, Value => True), - - when others => - (Is_Set => True, Value => False)); - end Is_Declaration; - ------------------- -- Write_Symbols -- ------------------- diff --git a/source/ada/lsp-ada_handlers-symbols.ads b/source/ada/lsp-ada_handlers-symbols.ads index 7c744dff4..8a80d5d65 100644 --- a/source/ada/lsp-ada_handlers-symbols.ads +++ b/source/ada/lsp-ada_handlers-symbols.ads @@ -15,25 +15,10 @@ -- of the license. -- ------------------------------------------------------------------------------ -with Libadalang.Analysis; - with LSP.Ada_Completions; -with LSP.Search; package LSP.Ada_Handlers.Symbols is - procedure Flat_Document_Symbols - (Self : in out Message_Handler'Class; - Unit : Libadalang.Analysis.Analysis_Unit; - Pattern : LSP.Search.Search_Pattern'Class; - Result : in out LSP.Structures.DocumentSymbol_Result); - - procedure Hierarchical_Document_Symbols - (Self : in out Message_Handler'Class; - Unit : Libadalang.Analysis.Analysis_Unit; - Pattern : LSP.Search.Search_Pattern'Class; - Result : in out LSP.Structures.DocumentSymbol_Vector); - procedure Write_Symbols (Self : in out Message_Handler'Class; Names : LSP.Ada_Completions.Completion_Maps.Map; diff --git a/source/ada/lsp-ada_handlers.adb b/source/ada/lsp-ada_handlers.adb index 4ce05eb2e..e119e940f 100644 --- a/source/ada/lsp-ada_handlers.adb +++ b/source/ada/lsp-ada_handlers.adb @@ -153,6 +153,12 @@ package body LSP.Ada_Handlers is return LSP.Structures.Location renames LSP.Ada_Handlers.Locations.To_LSP_Location; + overriding function To_LSP_Location + (Self : in out Message_Handler; + Node : Libadalang.Analysis.Ada_Node'Class) + return LSP.Structures.Location is + (LSP.Ada_Handlers.Locations.To_LSP_Location (Self, Node)); + overriding function Get_Node_At (Self : in out Message_Handler; Context : LSP.Ada_Contexts.Context; @@ -2337,49 +2343,6 @@ package body LSP.Ada_Handlers is Self.Sender.On_DocumentHighlight_Response (Id, Response); end On_DocumentHighlight_Request; - ------------------------------- - -- On_DocumentSymbol_Request -- - ------------------------------- - - overriding procedure On_DocumentSymbol_Request - (Self : in out Message_Handler; - Id : LSP.Structures.Integer_Or_Virtual_String; - Value : LSP.Structures.DocumentSymbolParams) - is - use type LSP.Structures.Boolean_Optional; - - Context : constant LSP.Ada_Context_Sets.Context_Access := - Self.Contexts.Get_Best_Context (Value.textDocument.uri); - - Unit : constant Libadalang.Analysis.Analysis_Unit := - Context.Get_AU (Self.To_File (Value.textDocument.uri)); - - Response : LSP.Structures.DocumentSymbol_Result; - - Pattern : constant LSP.Search.Search_Pattern'Class := - LSP.Search.Build - (Pattern => Value.query, - Case_Sensitive => Value.case_sensitive = LSP.Constants.True, - Whole_Word => Value.whole_word = LSP.Constants.True, - Negate => Value.negate = LSP.Constants.True, - Kind => - (if Value.kind.Is_Set - then Value.kind.Value - else LSP.Enumerations.Start_Word_Text)); - begin - if Self.Client.Hierarchical_Symbol then - Response := (Kind => LSP.Structures.Variant_2, Variant_2 => <>); - - LSP.Ada_Handlers.Symbols.Hierarchical_Document_Symbols - (Self, Unit, Pattern, Response.Variant_2); - else - LSP.Ada_Handlers.Symbols.Flat_Document_Symbols - (Self, Unit, Pattern, Response); - end if; - - Self.Sender.On_DocumentSymbol_Response (Id, Response); - end On_DocumentSymbol_Request; - ------------------------------- -- On_ExecuteCommand_Request -- ------------------------------- diff --git a/source/ada/lsp-ada_handlers.ads b/source/ada/lsp-ada_handlers.ads index 4cb441c0c..8c647c679 100644 --- a/source/ada/lsp-ada_handlers.ads +++ b/source/ada/lsp-ada_handlers.ads @@ -229,7 +229,7 @@ private and LSP.Server_Notification_Receivers.Server_Notification_Receiver and LSP.Ada_Job_Contexts.Ada_Job_Context with record - Client : LSP.Ada_Client_Capabilities.Client_Capability; + Client : aliased LSP.Ada_Client_Capabilities.Client_Capability; Configuration : aliased LSP.Ada_Configurations.Configuration; Contexts : LSP.Ada_Context_Sets.Context_Set; @@ -299,11 +299,6 @@ private Id : LSP.Structures.Integer_Or_Virtual_String; Value : LSP.Structures.DocumentHighlightParams); - overriding procedure On_DocumentSymbol_Request - (Self : in out Message_Handler; - Id : LSP.Structures.Integer_Or_Virtual_String; - Value : LSP.Structures.DocumentSymbolParams); - overriding procedure On_Exits_Notification (Self : in out Message_Handler); overriding procedure On_Shutdown_Request @@ -493,6 +488,10 @@ private -- Job_Context -- ------------------ + overriding function Client (Self : Message_Handler) return + access constant LSP.Ada_Client_Capabilities.Client_Capability'Class + is (Self.Client'Unchecked_Access); + overriding function Get_Configuration (Self : Message_Handler) return access constant LSP.Ada_Configurations.Configuration'Class is (Self.Configuration'Unchecked_Access); @@ -530,6 +529,11 @@ private Name_Node : Libadalang.Analysis.Name) return Libadalang.Analysis.Defining_Name; + overriding function To_LSP_Location + (Self : in out Message_Handler; + Node : Libadalang.Analysis.Ada_Node'Class) + return LSP.Structures.Location; + overriding procedure Append_Location (Self : in out Message_Handler; Result : in out LSP.Structures.Location_Vector; diff --git a/source/ada/lsp-ada_job_contexts.ads b/source/ada/lsp-ada_job_contexts.ads index 734e0c4f8..82569301c 100644 --- a/source/ada/lsp-ada_job_contexts.ads +++ b/source/ada/lsp-ada_job_contexts.ads @@ -29,6 +29,7 @@ with Laltools.Common; with VSS.Strings; +with LSP.Ada_Client_Capabilities; with LSP.Ada_Configurations; with LSP.Ada_Context_Sets; with LSP.Ada_Contexts; @@ -46,6 +47,10 @@ package LSP.Ada_Job_Contexts is URI : LSP.Structures.DocumentUri) return GNATCOLL.VFS.Virtual_File is abstract; + function Client (Self : Ada_Job_Context) return + access constant LSP.Ada_Client_Capabilities.Client_Capability'Class + is abstract; + function Get_Configuration (Self : Ada_Job_Context) return access constant LSP.Ada_Configurations.Configuration'Class is abstract; @@ -109,6 +114,11 @@ package LSP.Ada_Job_Contexts is (Laltools.Common.Get_Node_As_Name (Self.Get_Node_At (Context, Position)))); + function To_LSP_Location + (Self : in out Ada_Job_Context; + Node : Libadalang.Analysis.Ada_Node'Class) + return LSP.Structures.Location is abstract; + procedure Append_Location (Self : in out Ada_Job_Context; Result : in out LSP.Structures.Location_Vector; diff --git a/testsuite/ada_lsp/SA21-029.documentSymbol.with/test.json b/testsuite/ada_lsp/SA21-029.documentSymbol.with/test.json index 500cf727b..cfebcdc3e 100644 --- a/testsuite/ada_lsp/SA21-029.documentSymbol.with/test.json +++ b/testsuite/ada_lsp/SA21-029.documentSymbol.with/test.json @@ -109,7 +109,7 @@ }, "end": { "line": 0, - "character": 4 + "character": 17 } }, "children": [ diff --git a/testsuite/ada_lsp/UA28-007.Did_Change_Watched_Files_0/test.json b/testsuite/ada_lsp/UA28-007.Did_Change_Watched_Files_0/test.json index 0531d2d38..e6ef878df 100644 --- a/testsuite/ada_lsp/UA28-007.Did_Change_Watched_Files_0/test.json +++ b/testsuite/ada_lsp/UA28-007.Did_Change_Watched_Files_0/test.json @@ -499,12 +499,12 @@ }, "selectionRange": { "start": { - "line": 0, + "line": 1, "character": 0 }, "end": { - "line": 0, - "character": 4 + "line": 1, + "character": 9 } }, "children": [ @@ -644,7 +644,7 @@ }, "end": { "line": 0, - "character": 4 + "character": 9 } }, "children": [ diff --git a/testsuite/ada_lsp/UA28-007.Did_Create_Files_0/test.json b/testsuite/ada_lsp/UA28-007.Did_Create_Files_0/test.json index 88273baf1..151474bd3 100644 --- a/testsuite/ada_lsp/UA28-007.Did_Create_Files_0/test.json +++ b/testsuite/ada_lsp/UA28-007.Did_Create_Files_0/test.json @@ -458,12 +458,12 @@ }, "selectionRange": { "start": { - "line": 0, + "line": 1, "character": 0 }, "end": { - "line": 0, - "character": 4 + "line": 1, + "character": 9 } }, "children": [ @@ -687,7 +687,7 @@ }, "end": { "line": 0, - "character": 4 + "character": 9 } }, "children": [ @@ -810,12 +810,12 @@ }, "selectionRange": { "start": { - "line": 0, + "line": 1, "character": 0 }, "end": { - "line": 0, - "character": 4 + "line": 1, + "character": 9 } }, "children": [ @@ -974,7 +974,7 @@ }, "end": { "line": 0, - "character": 4 + "character": 9 } }, "children": [ diff --git a/testsuite/ada_lsp/UA28-007.Did_Delete_Files_0/test.json b/testsuite/ada_lsp/UA28-007.Did_Delete_Files_0/test.json index 053369f72..2763afc05 100644 --- a/testsuite/ada_lsp/UA28-007.Did_Delete_Files_0/test.json +++ b/testsuite/ada_lsp/UA28-007.Did_Delete_Files_0/test.json @@ -457,12 +457,12 @@ }, "selectionRange": { "start": { - "line": 0, + "line": 1, "character": 0 }, "end": { - "line": 0, - "character": 4 + "line": 1, + "character": 9 } }, "children": [ @@ -638,7 +638,7 @@ }, "end": { "line": 0, - "character": 4 + "character": 9 } }, "children": [ @@ -794,12 +794,12 @@ }, "selectionRange": { "start": { - "line": 0, + "line": 1, "character": 0 }, "end": { - "line": 0, - "character": 4 + "line": 1, + "character": 9 } }, "children": [ diff --git a/testsuite/ada_lsp/UA28-007.Did_Rename_Files_0/test.json b/testsuite/ada_lsp/UA28-007.Did_Rename_Files_0/test.json index 525d384c6..dcdf4fe79 100644 --- a/testsuite/ada_lsp/UA28-007.Did_Rename_Files_0/test.json +++ b/testsuite/ada_lsp/UA28-007.Did_Rename_Files_0/test.json @@ -888,7 +888,7 @@ }, "end": { "line": 0, - "character": 4 + "character": 9 } }, "children": [ @@ -1016,7 +1016,7 @@ }, "end": { "line": 0, - "character": 4 + "character": 9 } }, "children": [ From 227bd9ae11ec4ab1727a97f312879a24b121ebd5 Mon Sep 17 00:00:00 2001 From: Maxim Reznik Date: Mon, 15 Apr 2024 17:53:08 +0300 Subject: [PATCH 2/5] Rewrite `textDocument/semanticTokens/range` request as a job. Refs #1141 --- source/ada/lsp-ada_driver.adb | 10 +++ source/ada/lsp-ada_handlers.adb | 30 -------- source/ada/lsp-ada_handlers.ads | 12 ++-- source/ada/lsp-ada_job_contexts.ads | 5 ++ source/ada/lsp-ada_tokens_range.adb | 106 ++++++++++++++++++++++++++++ source/ada/lsp-ada_tokens_range.ads | 38 ++++++++++ 6 files changed, 165 insertions(+), 36 deletions(-) create mode 100644 source/ada/lsp-ada_tokens_range.adb create mode 100644 source/ada/lsp-ada_tokens_range.ads diff --git a/source/ada/lsp-ada_driver.adb b/source/ada/lsp-ada_driver.adb index d9c4194d8..0b5a2bafd 100644 --- a/source/ada/lsp-ada_driver.adb +++ b/source/ada/lsp-ada_driver.adb @@ -69,6 +69,7 @@ with LSP.Ada_Handlers.Refactor.Suppress_Seperate; with LSP.Ada_Handlers.Show_Dependencies_Commands; with LSP.Ada_Handlers.Source_Dirs_Commands; with LSP.Ada_Handlers.Suspend_Executions; +with LSP.Ada_Tokens_Range; with LSP.GNATCOLL_Trace_Streams; with LSP.GNATCOLL_Tracers; with LSP.GPR_Handlers; @@ -84,6 +85,7 @@ with LSP.Server_Requests.Declaration; with LSP.Server_Requests.DocumentSymbol; with LSP.Server_Requests.Hover; with LSP.Server_Requests.References; +with LSP.Server_Requests.Tokens_Range; with LSP.Servers; with LSP.Stdio_Streams; @@ -207,6 +209,10 @@ procedure LSP.Ada_Driver is LSP.Ada_Document_Symbol.Ada_Document_Symbol_Handler (Ada_Handler'Unchecked_Access); + Ada_Tokens_Range_Handler : aliased + LSP.Ada_Tokens_Range.Ada_Tokens_Range_Handler + (Ada_Handler'Unchecked_Access); + GPR_Did_Change_Doc_Handler : aliased LSP.GPR_Did_Change_Document.GPR_Did_Change_Handler (GPR_Handler'Unchecked_Access); @@ -431,6 +437,10 @@ begin (LSP.Server_Requests.DocumentSymbol.Request'Tag, Ada_Document_Symbol_Handler'Unchecked_Access); + Server.Register_Handler + (LSP.Server_Requests.Tokens_Range.Request'Tag, + Ada_Tokens_Range_Handler'Unchecked_Access); + Server.Register_Handler (LSP.Server_Requests.References.Request'Tag, Ada_References_Handler'Unchecked_Access); diff --git a/source/ada/lsp-ada_handlers.adb b/source/ada/lsp-ada_handlers.adb index e119e940f..269643d28 100644 --- a/source/ada/lsp-ada_handlers.adb +++ b/source/ada/lsp-ada_handlers.adb @@ -3684,36 +3684,6 @@ package body LSP.Ada_Handlers is Self.Sender.On_Tokens_Full_Response (Id, Response); end On_Tokens_Full_Request; - ----------------------------- - -- On_Tokens_Range_Request -- - ----------------------------- - - overriding procedure On_Tokens_Range_Request - (Self : in out Message_Handler; - Id : LSP.Structures.Integer_Or_Virtual_String; - Value : LSP.Structures.SemanticTokensRangeParams) - is - use type LSP.Ada_Documents.Document_Access; - - Document : constant LSP.Ada_Documents.Document_Access := - Self.Get_Open_Document (Value.textDocument.uri); - - Context : constant LSP.Ada_Context_Sets.Context_Access := - Self.Contexts.Get_Best_Context (Value.textDocument.uri); - - Response : LSP.Structures.SemanticTokens_Or_Null (Is_Null => False); - - Result : LSP.Structures.Natural_Vector renames - Response.Value.data; - begin - if Document /= null then - Result := Document.Get_Tokens - (Context.all, Self.Highlighter, Value.a_range); - end if; - - Self.Sender.On_Tokens_Full_Response (Id, Response); - end On_Tokens_Range_Request; - ------------------------------- -- On_TypeDefinition_Request -- ------------------------------- diff --git a/source/ada/lsp-ada_handlers.ads b/source/ada/lsp-ada_handlers.ads index 8c647c679..f02cdf6d4 100644 --- a/source/ada/lsp-ada_handlers.ads +++ b/source/ada/lsp-ada_handlers.ads @@ -238,7 +238,7 @@ private -- is known to the server, this context should map to the implicit -- project. - Highlighter : LSP.Ada_Highlighters.Ada_Highlighter; + Highlighter : aliased LSP.Ada_Highlighters.Ada_Highlighter; -- Semantic token highlighter for Ada Incremental_Text_Changes : Boolean; @@ -407,11 +407,6 @@ private Id : LSP.Structures.Integer_Or_Virtual_String; Value : LSP.Structures.SignatureHelpParams); - overriding procedure On_Tokens_Range_Request - (Self : in out Message_Handler; - Id : LSP.Structures.Integer_Or_Virtual_String; - Value : LSP.Structures.SemanticTokensRangeParams); - overriding procedure On_TypeDefinition_Request (Self : in out Message_Handler; Id : LSP.Structures.Integer_Or_Virtual_String; @@ -550,4 +545,9 @@ private overriding function Get_Trace_Handle (Self : Message_Handler) return GNATCOLL.Traces.Trace_Handle; + overriding function Get_Highlighter + (Self : in out Message_Handler) + return access constant LSP.Ada_Highlighters.Ada_Highlighter is + (Self.Highlighter'Unchecked_Access); + end LSP.Ada_Handlers; diff --git a/source/ada/lsp-ada_job_contexts.ads b/source/ada/lsp-ada_job_contexts.ads index 82569301c..144ff0c2c 100644 --- a/source/ada/lsp-ada_job_contexts.ads +++ b/source/ada/lsp-ada_job_contexts.ads @@ -34,6 +34,7 @@ with LSP.Ada_Configurations; with LSP.Ada_Context_Sets; with LSP.Ada_Contexts; with LSP.Ada_Documents; +with LSP.Ada_Highlighters; with LSP.Constants; with LSP.Locations; with LSP.Structures; @@ -75,6 +76,10 @@ package LSP.Ada_Job_Contexts is URI : LSP.Structures.DocumentUri) return LSP.Ada_Documents.Document_Access is abstract; + function Get_Highlighter + (Self : in out Ada_Job_Context) + return access constant LSP.Ada_Highlighters.Ada_Highlighter is abstract; + procedure Publish_Diagnostics (Self : in out Ada_Job_Context; Document : not null LSP.Ada_Documents.Document_Access; diff --git a/source/ada/lsp-ada_tokens_range.adb b/source/ada/lsp-ada_tokens_range.adb new file mode 100644 index 000000000..2bfd3721a --- /dev/null +++ b/source/ada/lsp-ada_tokens_range.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- Language Server Protocol -- +-- -- +-- Copyright (C) 2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. This software is distributed in the hope that it will be useful, -- +-- 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 -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +------------------------------------------------------------------------------ + +with GNATCOLL.VFS; + +with Libadalang.Analysis; + +with LSP.Ada_Context_Sets; +with LSP.Client_Message_Receivers; +with LSP.Server_Request_Jobs; +with LSP.Server_Requests.Tokens_Range; +with LSP.Structures; + +package body LSP.Ada_Tokens_Range is + + type Ada_Tokens_Range_Job + (Parent : not null access constant Ada_Tokens_Range_Handler) is limited + new LSP.Server_Request_Jobs.Server_Request_Job + (Priority => LSP.Server_Jobs.High) + with null record; + + type Ada_Tokens_Range_Job_Access is access all Ada_Tokens_Range_Job; + + overriding procedure Execute_Request + (Self : in out Ada_Tokens_Range_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status); + + ---------------- + -- Create_Job -- + ---------------- + + overriding function Create_Job + (Self : Ada_Tokens_Range_Handler; + Message : LSP.Server_Messages.Server_Message_Access) + return LSP.Server_Jobs.Server_Job_Access + is + Result : constant Ada_Tokens_Range_Job_Access := + new Ada_Tokens_Range_Job' + (Parent => Self'Unchecked_Access, + Request => LSP.Server_Request_Jobs.Request_Access (Message)); + begin + return LSP.Server_Jobs.Server_Job_Access (Result); + end Create_Job; + + --------------------- + -- Execute_Request -- + --------------------- + + overriding procedure Execute_Request + (Self : in out Ada_Tokens_Range_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status) + is + Message : LSP.Server_Requests.Tokens_Range.Request + renames LSP.Server_Requests.Tokens_Range.Request (Self.Message.all); + + Response : LSP.Structures.SemanticTokens_Or_Null (Is_Null => False); + + URI : LSP.Structures.DocumentUri renames + Message.Params.textDocument.uri; + + Context : constant LSP.Ada_Context_Sets.Context_Access := + Self.Parent.Context.Get_Best_Context (URI); + + File : constant GNATCOLL.VFS.Virtual_File := + Self.Parent.Context.To_File (URI); + + Unit : constant Libadalang.Analysis.Analysis_Unit := + Context.Get_AU (File); + + Result : LSP.Structures.Natural_Vector renames + Response.Value.data; + begin + Status := LSP.Server_Jobs.Done; + + if Unit.Root.Is_Null then + Client.On_Tokens_Range_Response (Message.Id, (Is_Null => True)); + + return; + end if; + + Result := + Self.Parent.Context.Get_Highlighter.Get_Tokens + (Unit, Context.Tracer.all, Message.Params.a_range); + + Client.On_Tokens_Range_Response (Message.Id, Response); + end Execute_Request; + +end LSP.Ada_Tokens_Range; diff --git a/source/ada/lsp-ada_tokens_range.ads b/source/ada/lsp-ada_tokens_range.ads new file mode 100644 index 000000000..7788564f2 --- /dev/null +++ b/source/ada/lsp-ada_tokens_range.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- Language Server Protocol -- +-- -- +-- Copyright (C) 2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. This software is distributed in the hope that it will be useful, -- +-- 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 -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +------------------------------------------------------------------------------ + +-- This package provides handler and job types for +-- textDocument/semanticTokens/range requests. + +with LSP.Ada_Job_Contexts; +with LSP.Server_Jobs; +with LSP.Server_Message_Handlers; +with LSP.Server_Messages; + +package LSP.Ada_Tokens_Range is + + type Ada_Tokens_Range_Handler + (Context : not null access LSP.Ada_Job_Contexts.Ada_Job_Context'Class) is + limited new LSP.Server_Message_Handlers.Server_Message_Handler + with null record; + + overriding function Create_Job + (Self : Ada_Tokens_Range_Handler; + Message : LSP.Server_Messages.Server_Message_Access) + return LSP.Server_Jobs.Server_Job_Access; + +end LSP.Ada_Tokens_Range; From a6c24cc884bbfb4acf7bfcd39f814e1f79166d22 Mon Sep 17 00:00:00 2001 From: Maxim Reznik Date: Wed, 17 Apr 2024 15:06:28 +0300 Subject: [PATCH 3/5] Rewrite token/full request as a job Refs #1141 --- source/ada/lsp-ada_documents.adb | 12 - source/ada/lsp-ada_documents.ads | 9 - source/ada/lsp-ada_driver.adb | 10 + source/ada/lsp-ada_handlers.adb | 36 - source/ada/lsp-ada_handlers.ads | 5 - source/ada/lsp-ada_highlighters.adb | 1168 ++++++++++++++------------- source/ada/lsp-ada_highlighters.ads | 108 ++- source/ada/lsp-ada_tokens_full.adb | 138 ++++ source/ada/lsp-ada_tokens_full.ads | 38 + 9 files changed, 888 insertions(+), 636 deletions(-) create mode 100644 source/ada/lsp-ada_tokens_full.adb create mode 100644 source/ada/lsp-ada_tokens_full.ads diff --git a/source/ada/lsp-ada_documents.adb b/source/ada/lsp-ada_documents.adb index 87352d461..8301e6d4a 100644 --- a/source/ada/lsp-ada_documents.adb +++ b/source/ada/lsp-ada_documents.adb @@ -1139,18 +1139,6 @@ package body LSP.Ada_Documents is is (Self.Unit (Context).Lookup_Token (Self.To_Source_Location (Position))); - ---------------- - -- Get_Tokens -- - ---------------- - - function Get_Tokens - (Self : Document'Class; Context : LSP.Ada_Contexts.Context; - Highlighter : LSP.Ada_Highlighters.Ada_Highlighter; - Span : LSP.Structures.A_Range := ((1, 1), (0, 0))) - return LSP.Structures.Natural_Vector - is - (Highlighter.Get_Tokens (Self.Unit (Context), Context.Tracer.all, Span)); - ----------------- -- Get_Word_At -- ----------------- diff --git a/source/ada/lsp-ada_documents.ads b/source/ada/lsp-ada_documents.ads index ae498ef5c..ec0d34c0d 100644 --- a/source/ada/lsp-ada_documents.ads +++ b/source/ada/lsp-ada_documents.ads @@ -32,7 +32,6 @@ with Pp.Command_Lines; limited with LSP.Ada_Contexts; limited with LSP.Ada_Handlers; with LSP.Ada_Completions; -with LSP.Ada_Highlighters; with LSP.Constants; with LSP.Diagnostic_Sources; with LSP.Text_Documents.Langkit_Documents; @@ -286,14 +285,6 @@ package LSP.Ada_Documents is return Libadalang.Common.Token_Reference; -- Return a token at the given Position. - function Get_Tokens - (Self : Document'Class; - Context : LSP.Ada_Contexts.Context; - Highlighter : LSP.Ada_Highlighters.Ada_Highlighter; - Span : LSP.Structures.A_Range := ((1, 1), (0, 0))) - return LSP.Structures.Natural_Vector; - -- Return semantic tokens in the document. See details in LSP specification - private type Name_Information is record diff --git a/source/ada/lsp-ada_driver.adb b/source/ada/lsp-ada_driver.adb index 0b5a2bafd..1c64f7481 100644 --- a/source/ada/lsp-ada_driver.adb +++ b/source/ada/lsp-ada_driver.adb @@ -69,6 +69,7 @@ with LSP.Ada_Handlers.Refactor.Suppress_Seperate; with LSP.Ada_Handlers.Show_Dependencies_Commands; with LSP.Ada_Handlers.Source_Dirs_Commands; with LSP.Ada_Handlers.Suspend_Executions; +with LSP.Ada_Tokens_Full; with LSP.Ada_Tokens_Range; with LSP.GNATCOLL_Trace_Streams; with LSP.GNATCOLL_Tracers; @@ -85,6 +86,7 @@ with LSP.Server_Requests.Declaration; with LSP.Server_Requests.DocumentSymbol; with LSP.Server_Requests.Hover; with LSP.Server_Requests.References; +with LSP.Server_Requests.Tokens_Full; with LSP.Server_Requests.Tokens_Range; with LSP.Servers; with LSP.Stdio_Streams; @@ -209,6 +211,10 @@ procedure LSP.Ada_Driver is LSP.Ada_Document_Symbol.Ada_Document_Symbol_Handler (Ada_Handler'Unchecked_Access); + Ada_Tokens_Full_Handler : aliased + LSP.Ada_Tokens_Full.Ada_Tokens_Full_Handler + (Ada_Handler'Unchecked_Access); + Ada_Tokens_Range_Handler : aliased LSP.Ada_Tokens_Range.Ada_Tokens_Range_Handler (Ada_Handler'Unchecked_Access); @@ -437,6 +443,10 @@ begin (LSP.Server_Requests.DocumentSymbol.Request'Tag, Ada_Document_Symbol_Handler'Unchecked_Access); + Server.Register_Handler + (LSP.Server_Requests.Tokens_Full.Request'Tag, + Ada_Tokens_Full_Handler'Unchecked_Access); + Server.Register_Handler (LSP.Server_Requests.Tokens_Range.Request'Tag, Ada_Tokens_Range_Handler'Unchecked_Access); diff --git a/source/ada/lsp-ada_handlers.adb b/source/ada/lsp-ada_handlers.adb index 269643d28..a46640248 100644 --- a/source/ada/lsp-ada_handlers.adb +++ b/source/ada/lsp-ada_handlers.adb @@ -146,13 +146,6 @@ package body LSP.Ada_Handlers is -- This function is handling Imprecise and Error results during Nameres by -- logging them and generating Diagnostics if needed. - function To_LSP_Location - (Self : in out Message_Handler'Class; - Node : Libadalang.Analysis.Ada_Node'Class; - Kind : LSP.Structures.AlsReferenceKind_Set := LSP.Constants.Empty) - return LSP.Structures.Location - renames LSP.Ada_Handlers.Locations.To_LSP_Location; - overriding function To_LSP_Location (Self : in out Message_Handler; Node : Libadalang.Analysis.Ada_Node'Class) @@ -3655,35 +3648,6 @@ package body LSP.Ada_Handlers is Self.Sender.On_Symbol_Response (Id, Response); end On_Symbol_Request; - ---------------------------- - -- On_Tokens_Full_Request -- - ---------------------------- - - overriding procedure On_Tokens_Full_Request - (Self : in out Message_Handler; - Id : LSP.Structures.Integer_Or_Virtual_String; - Value : LSP.Structures.SemanticTokensParams) - is - use type LSP.Ada_Documents.Document_Access; - - Document : constant LSP.Ada_Documents.Document_Access := - Self.Get_Open_Document (Value.textDocument.uri); - - Context : constant LSP.Ada_Context_Sets.Context_Access := - Self.Contexts.Get_Best_Context (Value.textDocument.uri); - - Response : LSP.Structures.SemanticTokens_Or_Null (Is_Null => False); - - Result : LSP.Structures.Natural_Vector renames - Response.Value.data; - begin - if Document /= null then - Result := Document.Get_Tokens (Context.all, Self.Highlighter); - end if; - - Self.Sender.On_Tokens_Full_Response (Id, Response); - end On_Tokens_Full_Request; - ------------------------------- -- On_TypeDefinition_Request -- ------------------------------- diff --git a/source/ada/lsp-ada_handlers.ads b/source/ada/lsp-ada_handlers.ads index f02cdf6d4..7fe158463 100644 --- a/source/ada/lsp-ada_handlers.ads +++ b/source/ada/lsp-ada_handlers.ads @@ -354,11 +354,6 @@ private Id : LSP.Structures.Integer_Or_Virtual_String; Value : LSP.Structures.DocumentFormattingParams); - overriding procedure On_Tokens_Full_Request - (Self : in out Message_Handler; - Id : LSP.Structures.Integer_Or_Virtual_String; - Value : LSP.Structures.SemanticTokensParams); - overriding procedure On_RangeFormatting_Request (Self : in out Message_Handler; Id : LSP.Structures.Integer_Or_Virtual_String; diff --git a/source/ada/lsp-ada_highlighters.adb b/source/ada/lsp-ada_highlighters.adb index 01e54b23c..0888faf86 100644 --- a/source/ada/lsp-ada_highlighters.adb +++ b/source/ada/lsp-ada_highlighters.adb @@ -15,13 +15,10 @@ -- of the license. -- ------------------------------------------------------------------------------ -with Ada.Containers.Vectors; - with GNATCOLL.Traces; with Langkit_Support.Slocs; with Langkit_Support.Text; -with Langkit_Support.Token_Data_Handlers; with Libadalang.Common; use Libadalang.Common; with VSS.Strings; @@ -34,74 +31,32 @@ package body LSP.Ada_Highlighters is Skip : LSP.Enumerations.SemanticTokenTypes renames LSP.Enumerations.macro; -- A dedicated token type for unsupported tokens - package Highlights_Holders is - type Highlights_Holder is tagged limited private; - -- Highlights_Holder stores style for each token in the range given - -- on initialization. - - procedure Initialize - (Self : in out Highlights_Holder'Class; - From : Libadalang.Common.Token_Reference; - To : Libadalang.Common.Token_Reference; - Empty : out Boolean); - -- Initialize holder by providing token range. If From or To is a trivia - -- holder uses corresponding non-trivia token instead. - - procedure Set_Token_Kind - (Self : in out Highlights_Holder'Class; - Token : Libadalang.Common.Token_Reference; - Value : LSP.Enumerations.SemanticTokenTypes) - with Pre => not Libadalang.Common.Is_Trivia (Token); - - procedure Set_Token_Modifier - (Self : in out Highlights_Holder'Class; - Token : Libadalang.Common.Token_Reference; - Value : LSP.Enumerations.SemanticTokenModifiers) - with Pre => not Libadalang.Common.Is_Trivia (Token); - - procedure Set_Token_Modifier - (Self : in out Highlights_Holder'Class; - From : Libadalang.Common.Token_Reference; - To : Libadalang.Common.Token_Reference; - Value : LSP.Enumerations.SemanticTokenModifiers) - with Pre => not Libadalang.Common.Is_Trivia (From) and then - not Libadalang.Common.Is_Trivia (To); - -- Set a modifier on each token in the range From .. To + function Is_Ghost_Root_Node + (Node : Libadalang.Analysis.Ada_Node'Class) return Boolean; + -- Check if given node is a declaration and has ghost aspect - type Modifier_Set is - array (LSP.Enumerations.SemanticTokenModifiers) of Boolean - with Pack; + type Is_Ghost_Root_Predicate is + new Libadalang.Iterators.Ada_Node_Predicate_Interface with null record; - Empty : constant Modifier_Set := (others => False); + overriding function Evaluate + (Self : in out Is_Ghost_Root_Predicate; + Node : Libadalang.Analysis.Ada_Node) return Boolean is + (Is_Ghost_Root_Node (Node)); - type Semantic_Token (Is_Set : Boolean := False) is record - Modifiers : Modifier_Set; + Is_Ghost_Root : Libadalang.Iterators.Ada_Node_Predicate; - case Is_Set is - when True => - Kind : LSP.Enumerations.SemanticTokenTypes; - when False => - null; - end case; - end record; - - function Get - (Self : Highlights_Holder'Class; - Token : Libadalang.Common.Token_Reference) - return Semantic_Token - with Pre => not Libadalang.Common.Is_Trivia (Token); - - private - - package Semantic_Token_Vectors is new Ada.Containers.Vectors - (Index_Type => Langkit_Support.Token_Data_Handlers.Token_Index, - Element_Type => Semantic_Token); + procedure Highlight_Name + (Self : Ada_Highlighter'Class; + Holder : in out Highlights_Holders.Highlights_Holder; + Node : Libadalang.Analysis.Name'Class); + -- Highlight given name with token Kind - type Highlights_Holder is tagged limited record - First : Langkit_Support.Token_Data_Handlers.Token_Index; - Vector : Semantic_Token_Vectors.Vector; - end record; - end Highlights_Holders; + procedure Get_Result + (Self : Ada_Highlighter'Class; + Holder : Highlights_Holders.Highlights_Holder; + From_Token : Libadalang.Common.Token_Reference; + To_Token : Libadalang.Common.Token_Reference; + Result : out LSP.Structures.Natural_Vector); function To_Int (Self : Ada_Highlighter'Class; @@ -109,6 +64,11 @@ package body LSP.Ada_Highlighters is with Inline; -- Cast set of modifiers to uinteger + Obsolescent : Unbounded_Text_Type; + Ada_Package : Unbounded_Text_Type; + System : Unbounded_Text_Type; + Interfaces : Unbounded_Text_Type; + ------------------------ -- Highlights_Holders -- ------------------------ @@ -146,12 +106,14 @@ package body LSP.Ada_Highlighters is or else Last < First then Self.First := 0; + Self.Last := 0; Self.Vector.Clear; Empty := True; return; end if; Self.First := Libadalang.Common.Index (First); + Self.Last := Libadalang.Common.Index (Last); Count := Libadalang.Common.Index (Last) - Self.First + 1; Self.Vector.Clear; @@ -185,10 +147,12 @@ package body LSP.Ada_Highlighters is Value : LSP.Enumerations.SemanticTokenModifiers) is use type Langkit_Support.Token_Data_Handlers.Token_Index; - Index : constant Langkit_Support.Token_Data_Handlers.Token_Index := - Libadalang.Common.Index (Token) - Self.First; + Index : constant Langkit_Support.Token_Data_Handlers.Token_Index'Base + := Libadalang.Common.Index (Token) - Self.First; begin - Self.Vector (Index).Modifiers (Value) := True; + if Libadalang.Common.Index (Token) in Self.First .. Self.Last then + Self.Vector (Index).Modifiers (Value) := True; + end if; end Set_Token_Modifier; ------------------------ @@ -207,12 +171,9 @@ package body LSP.Ada_Highlighters is Index : Langkit_Support.Token_Data_Handlers.Token_Index; begin loop - if Libadalang.Common.Index (Token) >= Self.First then + if Libadalang.Common.Index (Token) in Self.First .. Self.Last then Index := Libadalang.Common.Index (Token) - Self.First; - - if Index <= Self.Vector.Last_Index then - Self.Vector (Index).Modifiers (Value) := True; - end if; + Self.Vector (Index).Modifiers (Value) := True; end if; exit when Token = To; @@ -231,10 +192,12 @@ package body LSP.Ada_Highlighters is Value : LSP.Enumerations.SemanticTokenTypes) is use type Langkit_Support.Token_Data_Handlers.Token_Index; - Index : constant Langkit_Support.Token_Data_Handlers.Token_Index := - Libadalang.Common.Index (Token) - Self.First; + Index : constant Langkit_Support.Token_Data_Handlers.Token_Index'Base + := Libadalang.Common.Index (Token) - Self.First; begin - if Self.Vector (Index).Is_Set then + if Libadalang.Common.Index (Token) not in Self.First .. Self.Last then + null; -- Token index is out of expected range, skip it + elsif Self.Vector (Index).Is_Set then Self.Vector (Index).Kind := Value; else Self.Vector.Replace_Element @@ -276,496 +239,246 @@ package body LSP.Ada_Highlighters is then Libadalang.Common.Previous (Last_Token, Exclude_Trivia => True) else Last_Token); - function Is_Ghost_Root_Node - (Node : Libadalang.Analysis.Ada_Node'Class) return Boolean; - -- Check if given node is a declaration and has ghost aspect - - procedure Highlight_Token - (Token : Libadalang.Common.Token_Reference; - Kind : LSP.Enumerations.SemanticTokenTypes); - -- Highlight given Token with token Kind - - procedure Highlight_Token - (Token : Libadalang.Common.Token_Reference; - Kind : LSP.Enumerations.SemanticTokenModifiers); - -- Highlight given Token with token Kind - function Highlight_Node (Node : Libadalang.Analysis.Ada_Node'Class) return Libadalang.Common.Visit_Status; -- Highlight given node - procedure Highlight_Name - (Node : Libadalang.Analysis.Name'Class); - -- Highlight given name with token Kind - - procedure Get_Result - (Holder : Highlights_Holders.Highlights_Holder; - Result : out LSP.Structures.Natural_Vector); + Holder : Highlights_Holders.Highlights_Holder; - ---------------- - -- Get_Result -- - ---------------- + -------------------- + -- Highlight_Node -- + -------------------- - procedure Get_Result - (Holder : Highlights_Holders.Highlights_Holder; - Result : out LSP.Structures.Natural_Vector) + function Highlight_Node + (Node : Libadalang.Analysis.Ada_Node'Class) + return Libadalang.Common.Visit_Status is - use all type LSP.Enumerations.SemanticTokenTypes; - use type Langkit_Support.Slocs.Line_Number; - use type Langkit_Support.Slocs.Column_Number; - - subtype uint is Natural; - - Last : Langkit_Support.Slocs.Source_Location := (1, 1); - - Token : Libadalang.Common.Token_Reference := From_Token; + use all type LSP.Enumerations.SemanticTokenModifiers; begin - -- Scan over all tokens and find a corresponding value in Holder - while Token < To_Token loop - - declare - Value : constant Highlights_Holders.Semantic_Token := - Holder.Get (Token); - - Token_Data : constant Libadalang.Common.Token_Data_Type := - Libadalang.Common.Data (Token); - begin - declare - use type Highlights_Holders.Modifier_Set; - - Sloc_Range : constant - Langkit_Support.Slocs.Source_Location_Range := - Libadalang.Common.Sloc_Range (Token_Data); - - Start : constant Langkit_Support.Slocs.Source_Location := - Langkit_Support.Slocs.Start_Sloc (Sloc_Range); - - Map : constant array (Libadalang.Common.Token_Kind) of - LSP.Enumerations.SemanticTokenTypes := - (Ada_All .. Ada_Xor | Ada_With => keyword, - Ada_Par_Close .. Ada_Target => operator, - Ada_String | Ada_Char => LSP.Enumerations.string, - Ada_Decimal | Ada_Integer => number, - Ada_Comment => comment, - Ada_Identifier => Skip, - others => Skip); - - Mapped_Token : constant LSP.Enumerations.SemanticTokenTypes := - Map (Libadalang.Common.Kind (Token_Data)); - begin - -- If we have no token type calculated and no modifiers then - -- skip this token. For instance skip string literals those - -- are not in GHost code. This lets VS Code use rule-based - -- (lexical level) highlighter. Such highlighter is capable - -- to highlight character escape sequences inside a string - -- literal, or +/- before exponent in numeric literal, etc. - if Value.Is_Set or - (Mapped_Token /= Skip and then - Self.Token_Types.Contains (Mapped_Token) and then - Value.Modifiers /= Highlights_Holders.Empty) - then - pragma Assert - (Sloc_Range.End_Line = Sloc_Range.Start_Line); - - -- deltaLine - Result.Append (uint (Start.Line - Last.Line)); - -- deltaStartChar - Result.Append - (uint - (Start.Column - - (if Start.Line = Last.Line - then Last.Column else 1))); - -- length - Result.Append - (uint - (Sloc_Range.End_Column - Sloc_Range.Start_Column)); - -- tokenType - Result.Append - (Self.Token_Types - (if Value.Is_Set then Value.Kind else Mapped_Token)); - -- tokenModifiers - Result.Append (Self.To_Int (Value.Modifiers)); - - Last := Start; - end if; - end; + if Node.Token_End < From_Token or To_Token < Node.Token_Start then + -- Skip uninteresting nodes to speedup traversal + return Libadalang.Common.Over; + elsif Is_Ghost_Root_Node (Node) and then + Self.Token_Modifiers.Contains (documentation) + then + -- Mark all tokens in a ghost element as `documentation` + Holder.Set_Token_Modifier + (Node.Token_Start, Node.Token_End, documentation); + end if; - Token := Libadalang.Common.Next (Token, Exclude_Trivia => True); + case Node.Kind is + when Libadalang.Common.Ada_Name => + Self.Highlight_Name (Holder, Node.As_Name); - exit when not (Token < To_Token); - end; - end loop; - end Get_Result; + when others => + null; + end case; - -------------------- - -- Highlight_Name -- - -------------------- + return Libadalang.Common.Into; + exception + when E : Libadalang.Common.Property_Error => + if Highlighter_Debug.Is_Active then + Tracer.Trace_Exception + (E, + "In Highlight_Node at "); - procedure Highlight_Name (Node : Libadalang.Analysis.Name'Class) is - use all type LSP.Enumerations.SemanticTokenTypes; - use all type LSP.Enumerations.SemanticTokenModifiers; - use type Libadalang.Analysis.Defining_Name; + Tracer.Trace + (Langkit_Support.Text.Image (Node.Full_Sloc_Image)); + end if; - function To_Kind (Decl : Libadalang.Analysis.Basic_Decl) - return LSP.Enumerations.SemanticTokenTypes; + return Libadalang.Common.Into; + end Highlight_Node; - function Has_Abstract (Decl : Libadalang.Analysis.Basic_Decl) - return Boolean; + Root : constant Libadalang.Analysis.Ada_Node := + Libadalang.Analysis.Root (Unit); - function Is_Predefined (Decl : Libadalang.Analysis.Basic_Decl) - return Boolean; + Empty : Boolean; - ------------------ - -- Has_Abstract -- - ------------------ + begin + if Root.Is_Null or else + Libadalang.Common.No_Token in From_Token | To_Token + then + -- No tokens to highlight + return LSP.Structures.Empty; + end if; - function Has_Abstract (Decl : Libadalang.Analysis.Basic_Decl) - return Boolean - is - begin - case Decl.Kind is - when Ada_Abstract_Formal_Subp_Decl | - Ada_Abstract_Subp_Decl - => - return True; - when others => - return False; - end case; - end Has_Abstract; - - ------------------- - -- Is_Predefined -- - ------------------- - - function Is_Predefined (Decl : Libadalang.Analysis.Basic_Decl) - return Boolean - is + Holder.Initialize (From_Token, To_Token, Empty); - function Is_Synthetic - (Node : Libadalang.Analysis.Ada_Node'Class) return Boolean; + if Empty then + return LSP.Structures.Empty; + end if; - function Is_Synthetic - (Node : Libadalang.Analysis.Ada_Node'Class) return Boolean - is - Std : constant String := "__standard"; - File : constant String := Node.Unit.Get_Filename; - begin - return File'Length >= Std'Length - and then File (File'Last - Std'Length + 1 .. File'Last) = Std; - end Is_Synthetic; + -- Traverse whole tree, look for intresting nodes and mark their + -- tokens in Holder for further processing + Root.Traverse (Highlight_Node'Access); - Name : Libadalang.Analysis.Name := - Decl.P_Enclosing_Compilation_Unit.P_Decl.P_Defining_Name.F_Name; - begin - if Is_Synthetic (Decl) then - return True; -- In Standard package - end if; + return Result : LSP.Structures.Natural_Vector do + Self.Get_Result (Holder, From_Token, To_Token, Result); + end return; + end Get_Tokens; - while not Name.Is_Null and then Name.Kind = Ada_Dotted_Name loop - Name := Name.As_Dotted_Name.F_Prefix; - end loop; + ---------------- + -- Get_Result -- + ---------------- - if not Name.Is_Null - and then Name.Kind = Ada_Identifier - and then (Name.P_Name_Is (Self.Ada) - or Name.P_Name_Is (Self.System) - or Name.P_Name_Is (Self.Interfaces)) - then - return True; - else - return False; - end if; - end Is_Predefined; + procedure Get_Result + (Self : Ada_Highlighter'Class; + Holder : Highlights_Holder; + Unit : Libadalang.Analysis.Analysis_Unit; + Result : out LSP.Structures.Natural_Vector) is + begin + Self.Get_Result + (Holder.Value, Unit.First_Token, Unit.Last_Token, Result); + end Get_Result; - ------------- - -- To_Kind -- - ------------- + ---------------- + -- Get_Result -- + ---------------- - function To_Kind (Decl : Libadalang.Analysis.Basic_Decl) - return LSP.Enumerations.SemanticTokenTypes is - begin - case Decl.Kind is - when Libadalang.Common.Ada_Basic_Subp_Decl => - if Decl.Kind = Ada_Enum_Literal_Decl then - return enumMember; - else - return a_function; - end if; - when Libadalang.Common.Ada_Base_Type_Decl => - begin - if Decl.Kind = Ada_Single_Task_Type_Decl then - return variable; - elsif Decl.As_Base_Type_Decl.P_Is_Enum_Type then - return enum; - elsif Decl.As_Base_Type_Decl.P_Is_Interface_Type then - return an_interface; - elsif Decl.As_Base_Type_Decl.P_Is_Tagged_Type then - return class; - elsif Decl.As_Base_Type_Decl.P_Is_Record_Type then - return struct; - else - return a_type; - end if; - exception - when Property_Error => - -- If an error occurs while analysing the type (e.g. - -- incomplete code), default to "type". - return a_type; - end; + procedure Get_Result + (Self : Ada_Highlighter'Class; + Holder : Highlights_Holders.Highlights_Holder; + From_Token : Libadalang.Common.Token_Reference; + To_Token : Libadalang.Common.Token_Reference; + Result : out LSP.Structures.Natural_Vector) + is + use all type LSP.Enumerations.SemanticTokenTypes; + use type Langkit_Support.Slocs.Line_Number; + use type Langkit_Support.Slocs.Column_Number; - when Ada_Base_Formal_Param_Decl => - case Ada_Base_Formal_Param_Decl'(Decl.Kind) is - when Ada_Component_Decl => - return property; - when Ada_Discriminant_Spec => - return typeParameter; - when Ada_Param_Spec => - return parameter; - when Ada_Generic_Formal_Obj_Decl => - return variable; - when Ada_Generic_Formal_Package => - return namespace; - when Ada_Generic_Formal_Subp_Decl => - return a_function; - when Ada_Generic_Formal_Type_Decl => - return a_type; -- class/enum/interface/struct...? - when Ada_Synthetic_Formal_Param_Decl => - -- Synthetic nodes do not correspond to source text - return Skip; - end case; - - when Libadalang.Common.Ada_Base_Package_Decl => - return namespace; - - when Ada_Body_Node => - begin - declare - Spec : constant Libadalang.Analysis.Basic_Decl := - Decl.As_Body_Node.P_Decl_Part (True); - begin - if not Spec.Is_Null then - -- If there's a spec, use it to determine the kind - return To_Kind (Spec); - end if; - end; - exception - when Property_Error => - -- In case of errors while trying to obtain the spec - -- (e.g. incomplete code), continue the logic below - -- based on the body node. - null; - end; + subtype uint is Natural; - -- If the above fails, handle the kinds of bodies directly - case Ada_Body_Node'(Decl.Kind) is - when Ada_Accept_Stmt_Body => - return Skip; - when Ada_Base_Subp_Body => - return a_function; - when Ada_Package_Body_Stub => - return namespace; - when Ada_Protected_Body_Stub => - return variable; - when Ada_Subp_Body_Stub => - return a_function; - when Ada_Task_Body_Stub => - return variable; - when Ada_Entry_Body => - return variable; - when Ada_Package_Body => - return namespace; - when Ada_Protected_Body => - return variable; - when Ada_Task_Body => - return variable; - end case; - - when Ada_Entry_Index_Spec => - return variable; - when Ada_Exception_Decl => - return a_type; - when Ada_Exception_Handler => - return variable; - when Ada_Object_Decl => - return variable; - when Ada_For_Loop_Var_Decl => - return variable; - when Ada_Generic_Package_Decl => - return namespace; - when Ada_Generic_Subp_Decl => - return a_function; - when Ada_Generic_Package_Instantiation => - return namespace; - when Ada_Generic_Subp_Instantiation => - return a_function; - when Ada_Generic_Package_Renaming_Decl => - return namespace; - when Ada_Generic_Subp_Renaming_Decl => - return a_function; - when Ada_Named_Stmt_Decl => - return namespace; - when Ada_Number_Decl => - return number; - when Ada_Package_Renaming_Decl => - return namespace; - when Ada_Single_Protected_Decl => - return variable; - when Ada_Single_Task_Decl => - return variable; - when others => - return Skip; - end case; - end To_Kind; - - Failsafe_Def : Libadalang.Analysis.Refd_Def; - Def : Libadalang.Analysis.Defining_Name; - Decl : Libadalang.Analysis.Basic_Decl; - Kind : LSP.Enumerations.SemanticTokenTypes; - begin - if Node.Kind not in Ada_Identifier | Ada_String_Literal then - -- Highlight only identifiers and operator symbols - return; - end if; + Last : Langkit_Support.Slocs.Source_Location := (1, 1); - if Node.P_Is_Defining then - Def := Node.P_Enclosing_Defining_Name; + Token : Libadalang.Common.Token_Reference := From_Token; + begin + -- Scan over all tokens and find a corresponding value in Holder + while Token < To_Token loop - begin - declare - Is_Canonical : constant Boolean := - not Def.Is_Null and then Def.P_Canonical_Part = Def; - begin - if Is_Canonical then - Highlight_Token (Node.Token_Start, declaration); - else - Highlight_Token (Node.Token_Start, definition); - end if; - end; - exception - when Property_Error => - -- In case of errors (e.g. incomplete code) consider it - -- a canonical declaration. - Highlight_Token (Node.Token_Start, declaration); - end; - else - Failsafe_Def := Node.P_Failsafe_Referenced_Def_Name (True); - Def := Libadalang.Analysis.Defining_Name (Failsafe_Def.Def_Name); - end if; + declare + Value : constant Highlights_Holders.Semantic_Token := + Holder.Get (Token); - if Node.Kind in Libadalang.Common.Ada_Name then + Token_Data : constant Libadalang.Common.Token_Data_Type := + Libadalang.Common.Data (Token); + begin + declare + use type Highlights_Holders.Modifier_Set; + + Sloc_Range : constant + Langkit_Support.Slocs.Source_Location_Range := + Libadalang.Common.Sloc_Range (Token_Data); + + Start : constant Langkit_Support.Slocs.Source_Location := + Langkit_Support.Slocs.Start_Sloc (Sloc_Range); + + Map : constant array (Libadalang.Common.Token_Kind) of + LSP.Enumerations.SemanticTokenTypes := + (Ada_All .. Ada_Xor | Ada_With => keyword, + Ada_Par_Close .. Ada_Target => operator, + Ada_String | Ada_Char => LSP.Enumerations.string, + Ada_Decimal | Ada_Integer => number, + Ada_Comment => comment, + Ada_Identifier => Skip, + others => Skip); + + Mapped_Token : constant LSP.Enumerations.SemanticTokenTypes := + Map (Libadalang.Common.Kind (Token_Data)); begin - if Node.As_Name.P_Is_Write_Reference (True) then - Highlight_Token (Node.Token_Start, modification); + -- If we have no token type calculated and no modifiers then + -- skip this token. For instance skip string literals those + -- are not in GHost code. This lets VS Code use rule-based + -- (lexical level) highlighter. Such highlighter is capable + -- to highlight character escape sequences inside a string + -- literal, or +/- before exponent in numeric literal, etc. + if Value.Is_Set or + (Mapped_Token /= Skip and then + Self.Token_Types.Contains (Mapped_Token) and then + Value.Modifiers /= Highlights_Holders.Empty) + then + pragma Assert + (Sloc_Range.End_Line = Sloc_Range.Start_Line); + + -- deltaLine + Result.Append (uint (Start.Line - Last.Line)); + -- deltaStartChar + Result.Append + (uint + (Start.Column - + (if Start.Line = Last.Line + then Last.Column else 1))); + -- length + Result.Append + (uint + (Sloc_Range.End_Column - Sloc_Range.Start_Column)); + -- tokenType + Result.Append + (Self.Token_Types + (if Value.Is_Set then Value.Kind else Mapped_Token)); + -- tokenModifiers + Result.Append (Self.To_Int (Value.Modifiers)); + + Last := Start; end if; - exception - when Libadalang.Common.Property_Error => null; end; - end if; - if not Def.Is_Null then - Decl := Def.P_Basic_Decl; - - if not Decl.Is_Null then - Kind := To_Kind (Decl); - if Kind /= Skip then - Highlight_Token (Node.Token_Start, Kind); - end if; + Token := Libadalang.Common.Next (Token, Exclude_Trivia => True); - begin - if Kind in variable | parameter | typeParameter | property - and then Decl.P_Is_Constant_Object - then - Highlight_Token (Node.Token_Start, readonly); - end if; - exception - when Libadalang.Common.Property_Error => null; - end; + exit when not (Token < To_Token); + end; + end loop; + end Get_Result; - begin - if Decl.P_Is_Static_Decl then - Highlight_Token (Node.Token_Start, static); - end if; - exception - when Libadalang.Common.Property_Error => null; - end; + -------------------- + -- Highlight_Name -- + -------------------- - begin - -- P_Has_Aspect checks the existence of either an aspect or - -- a pragma. - if Def.P_Has_Aspect (Self.Obsolescent) then - Highlight_Token (Node.Token_Start, deprecated); - end if; - exception - when Libadalang.Common.Property_Error => null; - end; + procedure Highlight_Name + (Self : Ada_Highlighter'Class; + Holder : in out Highlights_Holders.Highlights_Holder; + Node : Libadalang.Analysis.Name'Class) + is + use all type LSP.Enumerations.SemanticTokenTypes; + use all type LSP.Enumerations.SemanticTokenModifiers; + use type Libadalang.Analysis.Defining_Name; - if Has_Abstract (Decl) then - Highlight_Token (Node.Token_Start, an_abstract); - end if; + procedure Highlight_Token + (Token : Libadalang.Common.Token_Reference; + Kind : LSP.Enumerations.SemanticTokenTypes); + -- Highlight given Token with token Kind - if Is_Predefined (Decl) then - Highlight_Token (Node.Token_Start, defaultLibrary); - end if; + procedure Highlight_Token + (Token : Libadalang.Common.Token_Reference; + Kind : LSP.Enumerations.SemanticTokenModifiers); + -- Highlight given Token with token Kind - return; - end if; - elsif Node.Kind = Ada_String_Literal then - return; -- This is not an operator symbol, so do nothing - end if; + function To_Kind (Decl : Libadalang.Analysis.Basic_Decl) + return LSP.Enumerations.SemanticTokenTypes; - if Node.P_Is_Operator_Name then - Highlight_Token (Node.Token_Start, operator); - else - -- In case of unresolved identifiers, do not set any semantic - -- highlighting - null; - end if; - end Highlight_Name; + function Has_Abstract (Decl : Libadalang.Analysis.Basic_Decl) + return Boolean; - Holder : Highlights_Holders.Highlights_Holder; + function Is_Predefined (Decl : Libadalang.Analysis.Basic_Decl) + return Boolean; - -------------------- - -- Highlight_Node -- - -------------------- + ------------------ + -- Has_Abstract -- + ------------------ - function Highlight_Node - (Node : Libadalang.Analysis.Ada_Node'Class) - return Libadalang.Common.Visit_Status + function Has_Abstract (Decl : Libadalang.Analysis.Basic_Decl) + return Boolean is - use all type LSP.Enumerations.SemanticTokenModifiers; begin - if Node.Token_End < From_Token or To_Token < Node.Token_Start then - -- Skip uninteresting nodes to speedup traversal - return Libadalang.Common.Over; - elsif Is_Ghost_Root_Node (Node) then - -- Mark all tokens in a ghost element as `documentation` - Holder.Set_Token_Modifier - (Node.Token_Start, Node.Token_End, documentation); - end if; - - case Node.Kind is - when Libadalang.Common.Ada_Name => - Highlight_Name (Node.As_Name); - + case Decl.Kind is + when Ada_Abstract_Formal_Subp_Decl | + Ada_Abstract_Subp_Decl + => + return True; when others => - null; + return False; end case; - - return Libadalang.Common.Into; - exception - when E : Libadalang.Common.Property_Error => - if Highlighter_Debug.Is_Active then - Tracer.Trace_Exception - (E, - "In Highlight_Node at "); - - Tracer.Trace - (Langkit_Support.Text.Image (Node.Full_Sloc_Image)); - end if; - - return Libadalang.Common.Into; - end Highlight_Node; + end Has_Abstract; --------------------- -- Highlight_Token -- @@ -775,10 +488,7 @@ package body LSP.Ada_Highlighters is (Token : Libadalang.Common.Token_Reference; Kind : LSP.Enumerations.SemanticTokenTypes) is begin - if Token < From_Token or To_Token < Token then - -- Skip uninteresting tokens - return; - elsif not Self.Token_Types.Contains (Kind) then + if not Self.Token_Types.Contains (Kind) then -- Skip unsupported tokens return; end if; @@ -794,10 +504,7 @@ package body LSP.Ada_Highlighters is (Token : Libadalang.Common.Token_Reference; Kind : LSP.Enumerations.SemanticTokenModifiers) is begin - if Token < From_Token or To_Token < Token then - -- Skip uninteresting tokens - return; - elsif not Self.Token_Modifiers.Contains (Kind) then + if not Self.Token_Modifiers.Contains (Kind) then -- Skip unsupported tokens return; end if; @@ -805,60 +512,322 @@ package body LSP.Ada_Highlighters is Holder.Set_Token_Modifier (Token, Kind); end Highlight_Token; - ------------------------ - -- Is_Ghost_Root_Node -- - ------------------------ + ------------------- + -- Is_Predefined -- + ------------------- - function Is_Ghost_Root_Node - (Node : Libadalang.Analysis.Ada_Node'Class) return Boolean is + function Is_Predefined (Decl : Libadalang.Analysis.Basic_Decl) + return Boolean + is + + function Is_Synthetic + (Node : Libadalang.Analysis.Ada_Node'Class) return Boolean; + + function Is_Synthetic + (Node : Libadalang.Analysis.Ada_Node'Class) return Boolean + is + Std : constant String := "__standard"; + File : constant String := Node.Unit.Get_Filename; + begin + return File'Length >= Std'Length + and then File (File'Last - Std'Length + 1 .. File'Last) = Std; + end Is_Synthetic; + + Name : Libadalang.Analysis.Name := + Decl.P_Enclosing_Compilation_Unit.P_Decl.P_Defining_Name.F_Name; begin - case Node.Kind is - when Libadalang.Common.Ada_Basic_Decl => - declare - Name : constant Libadalang.Analysis.Defining_Name := - Node.As_Basic_Decl.P_Defining_Name; + if Is_Synthetic (Decl) then + return True; -- In Standard package + end if; + + while not Name.Is_Null and then Name.Kind = Ada_Dotted_Name loop + Name := Name.As_Dotted_Name.F_Prefix; + end loop; + + if not Name.Is_Null + and then Name.Kind = Ada_Identifier + and then (Name.P_Name_Is (Ada_Package) + or Name.P_Name_Is (System) + or Name.P_Name_Is (Interfaces)) + then + return True; + else + return False; + end if; + end Is_Predefined; + + ------------- + -- To_Kind -- + ------------- + + function To_Kind (Decl : Libadalang.Analysis.Basic_Decl) + return LSP.Enumerations.SemanticTokenTypes is + begin + case Decl.Kind is + when Libadalang.Common.Ada_Basic_Subp_Decl => + if Decl.Kind = Ada_Enum_Literal_Decl then + return enumMember; + else + return a_function; + end if; + when Libadalang.Common.Ada_Base_Type_Decl => begin - return not Name.Is_Null and then Name.P_Is_Ghost_Code; + if Decl.Kind = Ada_Single_Task_Type_Decl then + return variable; + elsif Decl.As_Base_Type_Decl.P_Is_Enum_Type then + return enum; + elsif Decl.As_Base_Type_Decl.P_Is_Interface_Type then + return an_interface; + elsif Decl.As_Base_Type_Decl.P_Is_Tagged_Type then + return class; + elsif Decl.As_Base_Type_Decl.P_Is_Record_Type then + return struct; + else + return a_type; + end if; + exception + when Property_Error => + -- If an error occurs while analysing the type (e.g. + -- incomplete code), default to "type". + return a_type; end; - when Libadalang.Common.Ada_Aspect_Spec => - -- Mark all aspects as a ghost code, because most of aspects - -- are contract specifications. - return True; + + when Ada_Base_Formal_Param_Decl => + case Ada_Base_Formal_Param_Decl'(Decl.Kind) is + when Ada_Component_Decl => + return property; + when Ada_Discriminant_Spec => + return typeParameter; + when Ada_Param_Spec => + return parameter; + when Ada_Generic_Formal_Obj_Decl => + return variable; + when Ada_Generic_Formal_Package => + return namespace; + when Ada_Generic_Formal_Subp_Decl => + return a_function; + when Ada_Generic_Formal_Type_Decl => + return a_type; -- class/enum/interface/struct...? + when Ada_Synthetic_Formal_Param_Decl => + -- Synthetic nodes do not correspond to source text + return Skip; + end case; + + when Libadalang.Common.Ada_Base_Package_Decl => + return namespace; + + when Ada_Body_Node => + begin + declare + Spec : constant Libadalang.Analysis.Basic_Decl := + Decl.As_Body_Node.P_Decl_Part (True); + begin + if not Spec.Is_Null then + -- If there's a spec, use it to determine the kind + return To_Kind (Spec); + end if; + end; + exception + when Property_Error => + -- In case of errors while trying to obtain the spec + -- (e.g. incomplete code), continue the logic below + -- based on the body node. + null; + end; + + -- If the above fails, handle the kinds of bodies directly + case Ada_Body_Node'(Decl.Kind) is + when Ada_Accept_Stmt_Body => + return Skip; + when Ada_Base_Subp_Body => + return a_function; + when Ada_Package_Body_Stub => + return namespace; + when Ada_Protected_Body_Stub => + return variable; + when Ada_Subp_Body_Stub => + return a_function; + when Ada_Task_Body_Stub => + return variable; + when Ada_Entry_Body => + return variable; + when Ada_Package_Body => + return namespace; + when Ada_Protected_Body => + return variable; + when Ada_Task_Body => + return variable; + end case; + + when Ada_Entry_Index_Spec => + return variable; + when Ada_Exception_Decl => + return a_type; + when Ada_Exception_Handler => + return variable; + when Ada_Object_Decl => + return variable; + when Ada_For_Loop_Var_Decl => + return variable; + when Ada_Generic_Package_Decl => + return namespace; + when Ada_Generic_Subp_Decl => + return a_function; + when Ada_Generic_Package_Instantiation => + return namespace; + when Ada_Generic_Subp_Instantiation => + return a_function; + when Ada_Generic_Package_Renaming_Decl => + return namespace; + when Ada_Generic_Subp_Renaming_Decl => + return a_function; + when Ada_Named_Stmt_Decl => + return namespace; + when Ada_Number_Decl => + return number; + when Ada_Package_Renaming_Decl => + return namespace; + when Ada_Single_Protected_Decl => + return variable; + when Ada_Single_Task_Decl => + return variable; when others => - return False; + return Skip; end case; - exception - when Libadalang.Common.Property_Error => - return False; - end Is_Ghost_Root_Node; + end To_Kind; - Root : constant Libadalang.Analysis.Ada_Node := - Libadalang.Analysis.Root (Unit); + Failsafe_Def : Libadalang.Analysis.Refd_Def; + Def : Libadalang.Analysis.Defining_Name; + Decl : Libadalang.Analysis.Basic_Decl; + Kind : LSP.Enumerations.SemanticTokenTypes; + begin + if Node.Kind not in Ada_Identifier | Ada_String_Literal then + -- Highlight only identifiers and operator symbols + return; + end if; - Empty : Boolean; + if Node.P_Is_Defining then + Def := Node.P_Enclosing_Defining_Name; - begin - if Root.Is_Null or else - Libadalang.Common.No_Token in From_Token | To_Token - then - -- No tokens to highlight - return LSP.Structures.Empty; + begin + declare + Is_Canonical : constant Boolean := + not Def.Is_Null and then Def.P_Canonical_Part = Def; + begin + if Is_Canonical then + Highlight_Token (Node.Token_Start, declaration); + else + Highlight_Token (Node.Token_Start, definition); + end if; + end; + exception + when Property_Error => + -- In case of errors (e.g. incomplete code) consider it + -- a canonical declaration. + Highlight_Token (Node.Token_Start, declaration); + end; + else + Failsafe_Def := Node.P_Failsafe_Referenced_Def_Name (True); + Def := Libadalang.Analysis.Defining_Name (Failsafe_Def.Def_Name); end if; - Holder.Initialize (From_Token, To_Token, Empty); + if Node.Kind in Libadalang.Common.Ada_Name then + begin + if Node.As_Name.P_Is_Write_Reference (True) then + Highlight_Token (Node.Token_Start, modification); + end if; + exception + when Libadalang.Common.Property_Error => null; + end; + end if; - if Empty then - return LSP.Structures.Empty; + if not Def.Is_Null then + Decl := Def.P_Basic_Decl; + + if not Decl.Is_Null then + Kind := To_Kind (Decl); + if Kind /= Skip then + Highlight_Token (Node.Token_Start, Kind); + end if; + + begin + if Kind in variable | parameter | typeParameter | property + and then Decl.P_Is_Constant_Object + then + Highlight_Token (Node.Token_Start, readonly); + end if; + exception + when Libadalang.Common.Property_Error => null; + end; + + begin + if Decl.P_Is_Static_Decl then + Highlight_Token (Node.Token_Start, static); + end if; + exception + when Libadalang.Common.Property_Error => null; + end; + + begin + -- P_Has_Aspect checks the existence of either an aspect or + -- a pragma. + if Def.P_Has_Aspect (Obsolescent) then + Highlight_Token (Node.Token_Start, deprecated); + end if; + exception + when Libadalang.Common.Property_Error => null; + end; + + if Has_Abstract (Decl) then + Highlight_Token (Node.Token_Start, an_abstract); + end if; + + if Is_Predefined (Decl) then + Highlight_Token (Node.Token_Start, defaultLibrary); + end if; + + return; + end if; + elsif Node.Kind = Ada_String_Literal then + return; -- This is not an operator symbol, so do nothing end if; - -- Traverse whole tree, look for intresting nodes and mark their - -- tokens in Holder for further processing - Root.Traverse (Highlight_Node'Access); + if Node.P_Is_Operator_Name then + Highlight_Token (Node.Token_Start, operator); + else + -- In case of unresolved identifiers, do not set any semantic + -- highlighting + null; + end if; + end Highlight_Name; - return Result : LSP.Structures.Natural_Vector do - Get_Result (Holder, Result); - end return; - end Get_Tokens; + -------------------- + -- Highlight_Node -- + -------------------- + + procedure Highlight_Node + (Self : Ada_Highlighter'Class; + Holder : in out Highlights_Holder; + Node : Libadalang.Analysis.Ada_Node'Class) is + begin + if Is_Ghost_Root_Node (Node) then + -- Mark all tokens in a ghost element as `documentation` + Holder.Value.Set_Token_Modifier + (Node.Token_Start, Node.Token_End, LSP.Enumerations.documentation); + end if; + + case Node.Kind is + when Libadalang.Common.Ada_Name => + Self.Highlight_Name (Holder.Value, Node.As_Name); + + when others => + null; + end case; + + exception + when Libadalang.Common.Property_Error => + null; + end Highlight_Node; ---------------- -- Initialize -- @@ -948,12 +917,71 @@ package body LSP.Ada_Highlighters is Append_Modifier (documentation, "documentation"); Append_Modifier (defaultLibrary, "defaultLibrary"); - Self.Obsolescent := +"Obsolescent"; - Self.Ada := +"Ada"; - Self.System := +"System"; - Self.Interfaces := +"Interfaces"; + Obsolescent := +"Obsolescent"; + Ada_Package := +"Ada"; + System := +"System"; + Interfaces := +"Interfaces"; + + Is_Ghost_Root.Set (Is_Ghost_Root_Predicate'(null record)); + end Initialize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Holder : out Highlights_Holder; + Unit : Libadalang.Analysis.Analysis_Unit) + is + Ignore : Boolean; + begin + Highlights_Holders.Initialize + (Holder.Value, + Unit.First_Token, + Unit.Last_Token, + Ignore); end Initialize; + ------------------------ + -- Is_Ghost_Root_Node -- + ------------------------ + + function Is_Ghost_Root_Node + (Node : Libadalang.Analysis.Ada_Node'Class) return Boolean is + begin + case Node.Kind is + when Libadalang.Common.Ada_Basic_Decl => + declare + Name : constant Libadalang.Analysis.Defining_Name := + Node.As_Basic_Decl.P_Defining_Name; + begin + return not Name.Is_Null and then Name.P_Is_Ghost_Code; + end; + when Libadalang.Common.Ada_Aspect_Spec => + -- Mark all aspects as a ghost code, because most of aspects + -- are contract specifications. + return True; + when others => + return False; + end case; + exception + when Libadalang.Common.Property_Error => + return False; + end Is_Ghost_Root_Node; + + ----------------------- + -- Need_Highlighting -- + ----------------------- + + function Need_Highlighting return Libadalang.Iterators.Ada_Node_Predicate is + use Libadalang.Iterators; + + begin + return Libadalang.Iterators.Kind_In + (Libadalang.Common.Ada_Name'First, Libadalang.Common.Ada_Name'Last) + or Is_Ghost_Root; + end Need_Highlighting; + ------------ -- To_Int -- ------------ diff --git a/source/ada/lsp-ada_highlighters.ads b/source/ada/lsp-ada_highlighters.ads index 4e4a56382..7c0b6bd84 100644 --- a/source/ada/lsp-ada_highlighters.ads +++ b/source/ada/lsp-ada_highlighters.ads @@ -16,9 +16,14 @@ ------------------------------------------------------------------------------ with Ada.Containers.Hashed_Maps; +with Ada.Containers.Vectors; with Ada.Strings.Wide_Wide_Unbounded; +with Langkit_Support.Token_Data_Handlers; + with Libadalang.Analysis; +with Libadalang.Common; +with Libadalang.Iterators; with LSP.Ada_Client_Capabilities; with LSP.Enumerations; @@ -44,8 +49,107 @@ package LSP.Ada_Highlighters is -- If Span isn't empty then return unit tokens in given Span, otherwise -- return all tokens in the Unit. + function Need_Highlighting return Libadalang.Iterators.Ada_Node_Predicate; + -- Predicate to filter node for highlighing + + type Highlights_Holder is limited private; + -- A holder to keep data about highlighted tokens + + procedure Initialize + (Holder : out Highlights_Holder; + Unit : Libadalang.Analysis.Analysis_Unit); + -- Initialuze holder to keep highlighting information for every token + -- in the Unit + + procedure Highlight_Node + (Self : Ada_Highlighter'Class; + Holder : in out Highlights_Holder; + Node : Libadalang.Analysis.Ada_Node'Class); + -- Highlight tokens of the Node and keep highlighting in the Holder + + procedure Get_Result + (Self : Ada_Highlighter'Class; + Holder : Highlights_Holder; + Unit : Libadalang.Analysis.Analysis_Unit; + Result : out LSP.Structures.Natural_Vector); + -- Retrive highliting from Holder and encode it into Result + private + package Highlights_Holders is + type Highlights_Holder is tagged limited private; + -- Highlights_Holder stores style for each token in the range given + -- on initialization. + + procedure Initialize + (Self : in out Highlights_Holder'Class; + From : Libadalang.Common.Token_Reference; + To : Libadalang.Common.Token_Reference; + Empty : out Boolean); + -- Initialize holder by providing token range. If From or To is a trivia + -- holder uses corresponding non-trivia token instead. + + procedure Set_Token_Kind + (Self : in out Highlights_Holder'Class; + Token : Libadalang.Common.Token_Reference; + Value : LSP.Enumerations.SemanticTokenTypes) + with Pre => not Libadalang.Common.Is_Trivia (Token); + + procedure Set_Token_Modifier + (Self : in out Highlights_Holder'Class; + Token : Libadalang.Common.Token_Reference; + Value : LSP.Enumerations.SemanticTokenModifiers) + with Pre => not Libadalang.Common.Is_Trivia (Token); + + procedure Set_Token_Modifier + (Self : in out Highlights_Holder'Class; + From : Libadalang.Common.Token_Reference; + To : Libadalang.Common.Token_Reference; + Value : LSP.Enumerations.SemanticTokenModifiers) + with Pre => not Libadalang.Common.Is_Trivia (From) and then + not Libadalang.Common.Is_Trivia (To); + -- Set a modifier on each token in the range From .. To + + type Modifier_Set is + array (LSP.Enumerations.SemanticTokenModifiers) of Boolean + with Pack; + + Empty : constant Modifier_Set := (others => False); + + type Semantic_Token (Is_Set : Boolean := False) is record + Modifiers : Modifier_Set; + + case Is_Set is + when True => + Kind : LSP.Enumerations.SemanticTokenTypes; + when False => + null; + end case; + end record; + + function Get + (Self : Highlights_Holder'Class; + Token : Libadalang.Common.Token_Reference) + return Semantic_Token + with Pre => not Libadalang.Common.Is_Trivia (Token); + + private + + package Semantic_Token_Vectors is new Ada.Containers.Vectors + (Index_Type => Langkit_Support.Token_Data_Handlers.Token_Index, + Element_Type => Semantic_Token); + + type Highlights_Holder is tagged limited record + First : Langkit_Support.Token_Data_Handlers.Token_Index; + Last : Langkit_Support.Token_Data_Handlers.Token_Index; + Vector : Semantic_Token_Vectors.Vector; + end record; + end Highlights_Holders; + + type Highlights_Holder is limited record + Value : Highlights_Holders.Highlights_Holder; + end record; + function Hash (Value : LSP.Enumerations.SemanticTokenTypes) return Ada.Containers.Hash_Type is (Ada.Containers.Hash_Type @@ -76,10 +180,6 @@ private type Ada_Highlighter is tagged limited record Token_Types : Token_Type_Maps.Map; Token_Modifiers : Token_Modifier_Maps.Map; - Obsolescent : Unbounded_Text_Type; - Ada : Unbounded_Text_Type; - System : Unbounded_Text_Type; - Interfaces : Unbounded_Text_Type; end record; end LSP.Ada_Highlighters; diff --git a/source/ada/lsp-ada_tokens_full.adb b/source/ada/lsp-ada_tokens_full.adb new file mode 100644 index 000000000..438f1d806 --- /dev/null +++ b/source/ada/lsp-ada_tokens_full.adb @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- Language Server Protocol -- +-- -- +-- Copyright (C) 2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. This software is distributed in the hope that it will be useful, -- +-- 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 -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with GNATCOLL.VFS; + +with Libadalang.Analysis; +with Libadalang.Iterators; + +with LSP.Ada_Context_Sets; +with LSP.Ada_Highlighters; +with LSP.Client_Message_Receivers; +with LSP.Server_Request_Jobs; +with LSP.Server_Requests.Tokens_Full; +with LSP.Structures; + +package body LSP.Ada_Tokens_Full is + + type Traverse_Iterator_Access is access + Libadalang.Iterators.Traverse_Iterator'Class; + + procedure Free is new Ada.Unchecked_Deallocation + (Libadalang.Iterators.Traverse_Iterator'Class, Traverse_Iterator_Access); + + type Tokens_Full_Job + (Parent : not null access constant Ada_Tokens_Full_Handler) is limited + new LSP.Server_Request_Jobs.Server_Request_Job + (Priority => LSP.Server_Jobs.Low) + with record + Unit : Libadalang.Analysis.Analysis_Unit; + Cursor : Traverse_Iterator_Access; + Holder : LSP.Ada_Highlighters.Highlights_Holder; + end record; + + overriding procedure Execute_Request + (Self : in out Tokens_Full_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status); + + type Tokens_Full_Job_Access is access all Tokens_Full_Job; + + ---------------- + -- Create_Job -- + ---------------- + + overriding function Create_Job + (Self : Ada_Tokens_Full_Handler; + Message : LSP.Server_Messages.Server_Message_Access) + return LSP.Server_Jobs.Server_Job_Access + is + Value : LSP.Structures.SemanticTokensParams + renames LSP.Server_Requests.Tokens_Full.Request + (Message.all).Params; + + File : constant GNATCOLL.VFS.Virtual_File := + Self.Context.To_File (Value.textDocument.uri); + + Context : constant LSP.Ada_Context_Sets.Context_Access := + Self.Context.Get_Best_Context (Value.textDocument.uri); + + Unit : constant Libadalang.Analysis.Analysis_Unit := + Context.Get_AU (File); + + Job : constant Tokens_Full_Job_Access := + (new Tokens_Full_Job' + (Parent => Self'Unchecked_Access, + Request => LSP.Server_Request_Jobs.Request_Access (Message), + Unit => Unit, + Cursor => new Libadalang.Iterators.Traverse_Iterator'Class' + (Libadalang.Iterators.Find + (Unit.Root, LSP.Ada_Highlighters.Need_Highlighting)), + Holder => <>)); + + begin + LSP.Ada_Highlighters.Initialize (Job.Holder, Unit); + return LSP.Server_Jobs.Server_Job_Access (Job); + end Create_Job; + + --------------------- + -- Execute_Request -- + --------------------- + + overriding procedure Execute_Request + (Self : in out Tokens_Full_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status) + is + Message : LSP.Server_Requests.Tokens_Full.Request + renames LSP.Server_Requests.Tokens_Full.Request (Self.Message.all); + + Element : Libadalang.Analysis.Ada_Node; + begin + Status := LSP.Server_Jobs.Continue; + + for J in 1 .. 300 loop + if Self.Cursor.Next (Element) then + Self.Parent.Context.Get_Highlighter.Highlight_Node + (Self.Holder, Element); + + else + declare + Response : LSP.Structures.SemanticTokens_Or_Null + (Is_Null => False); + begin + + Self.Parent.Context.Get_Highlighter.Get_Result + (Self.Holder, Self.Unit, Response.Value.data); + + Client.On_Tokens_Full_Response (Message.Id, Response); + + Free (Self.Cursor); + + Status := LSP.Server_Jobs.Done; + + exit; + end; + end if; + end loop; + end Execute_Request; + +end LSP.Ada_Tokens_Full; diff --git a/source/ada/lsp-ada_tokens_full.ads b/source/ada/lsp-ada_tokens_full.ads new file mode 100644 index 000000000..39800d34d --- /dev/null +++ b/source/ada/lsp-ada_tokens_full.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- Language Server Protocol -- +-- -- +-- Copyright (C) 2024, 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- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. This software is distributed in the hope that it will be useful, -- +-- 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 -- +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- +-- of the license. -- +------------------------------------------------------------------------------ + +-- This package provides handler and job types for +-- textDocument/semanticTokens/full requests. + +with LSP.Ada_Job_Contexts; +with LSP.Server_Jobs; +with LSP.Server_Message_Handlers; +with LSP.Server_Messages; + +package LSP.Ada_Tokens_Full is + + type Ada_Tokens_Full_Handler + (Context : not null access LSP.Ada_Job_Contexts.Ada_Job_Context'Class) is + limited new LSP.Server_Message_Handlers.Server_Message_Handler + with null record; + + overriding function Create_Job + (Self : Ada_Tokens_Full_Handler; + Message : LSP.Server_Messages.Server_Message_Access) + return LSP.Server_Jobs.Server_Job_Access; + +end LSP.Ada_Tokens_Full; From 89a6e5bb6dc80c17585c7bee0ad61e8329e7a29e Mon Sep 17 00:00:00 2001 From: Elie Richa Date: Fri, 12 Apr 2024 14:22:59 +0000 Subject: [PATCH 4/5] Update vscode XFAILs to new format For eng/ide/ada_language_server#1321 --- integration/vscode/ada/xfail.yaml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/integration/vscode/ada/xfail.yaml b/integration/vscode/ada/xfail.yaml index 6bc7542b9..26dccf59a 100644 --- a/integration/vscode/ada/xfail.yaml +++ b/integration/vscode/ada/xfail.yaml @@ -1,6 +1,8 @@ -# Each XFAIL entry should be an array of strings with the following content: +# This file should contain XFAILs compatible with the e3-convert-xunit tool from +# e3-testsuite. The format should be a mapping from test names to expected +# failure messages. # -# - [, , , '', ] +# For example: # -# Use an empty string for the platform if the XFAIL should apply everywhere. -xfails: +# "Task-Execution-gnatsas-analyze-report": "Some reason" +# "Task-Execution-gnatdoc": "Some other reason" From 77eeea33f73c8e0d448716c01b0e4ab5daf8c33a Mon Sep 17 00:00:00 2001 From: Elie Richa Date: Fri, 12 Apr 2024 14:54:54 +0000 Subject: [PATCH 5/5] Update CI to use new test results location --- .gitlab-ci.yml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 624f01a19..cc1f5200c 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -107,7 +107,6 @@ test-als: # Job artifacts must be produced in the project directory, so we do it at # the end of the job to avoid changing Anod checkouts halfway through the # job and triggering useless rebuilds. - - echo -e "\e[0Ksection_start:`date +%s`:prepare_artifacts[collapsed=true]\r\e[0KPrepare job artifacts" # Process the als test report - e3-testsuite-report --failure-exit-code 1 @@ -115,7 +114,6 @@ test-als: $ALS_BUILD_SPACE/results/new/ || FAILED=true # Include Anod logs - cp -r $ANOD_DEFAULT_SANDBOX_DIR/log $CI_PROJECT_DIR/anod-logs - - echo -e "\e[0Ksection_end:`date +%s`:prepare_artifacts\r\e[0K" - if [ ! -z ${FAILED+x} ]; then echo "There was at least one testcase failure" && exit 1; fi @@ -150,15 +148,13 @@ test-vscode-extension: # Job artifacts must be produced in the project directory, so we do it at # the end of the job to avoid changing Anod checkouts halfway through the # job and triggering useless rebuilds. - - echo -e "\e[0Ksection_start:`date +%s`:prepare_artifacts[collapsed=true]\r\e[0KPrepare job artifacts" # Process the vscode-extension test report - e3-testsuite-report --failure-exit-code 1 --xunit-output $CI_PROJECT_DIR/vscode_xunit_output.xml - $VSCODE_BUILD_SPACE/results/new/ || FAILED=true + $VSCODE_BUILD_SPACE/results/ || FAILED=true # Include Anod logs - cp -r $ANOD_DEFAULT_SANDBOX_DIR/log $CI_PROJECT_DIR/anod-logs - - echo -e "\e[0Ksection_end:`date +%s`:prepare_artifacts\r\e[0K" - if [ ! -z ${FAILED+x} ]; then echo "There was at least one testcase failure" && exit 1; fi