From 28d927b186bb46d732f99492025fac424cf3948c Mon Sep 17 00:00:00 2001 From: Maxim Reznik Date: Tue, 23 Apr 2024 14:41:21 +0300 Subject: [PATCH 1/3] Run `alr show` and `alr printenv` in a sequence instead of as concurrent processes. Fixes ada_language_server#1339, refs #1192 on github --- source/ada/lsp-ada_handlers-alire.adb | 220 +++++++++++++++----------- 1 file changed, 132 insertions(+), 88 deletions(-) diff --git a/source/ada/lsp-ada_handlers-alire.adb b/source/ada/lsp-ada_handlers-alire.adb index 9957a2b17..d81c8e7f5 100644 --- a/source/ada/lsp-ada_handlers-alire.adb +++ b/source/ada/lsp-ada_handlers-alire.adb @@ -52,11 +52,15 @@ package body LSP.Ada_Handlers.Alire is Error : Integer); procedure Start_Alire - (Listener : in out Process_Listener'Class; - ALR : String; + (ALR : String; Option_1 : String; Option_2 : String; - Root : String); + Root : String; + Error : out VSS.Strings.Virtual_String; + Lines : out VSS.String_Vectors.Virtual_String_Vector); + + Anchored : constant VSS.Regular_Expressions.Match_Options := + (VSS.Regular_Expressions.Anchored_Match => True); -------------------- -- Error_Occurred -- @@ -81,10 +85,6 @@ package body LSP.Ada_Handlers.Alire is Environment : in out GPR2.Environment.Object) is use type GNAT.OS_Lib.String_Access; - use type Spawn.Process_Exit_Code; - use type Spawn.Process_Exit_Status; - use type Spawn.Process_Status; - use all type VSS.Regular_Expressions.Match_Option; ALR : GNAT.OS_Lib.String_Access := GNAT.OS_Lib.Locate_Exec_On_Path ("alr"); @@ -100,13 +100,7 @@ package body LSP.Ada_Handlers.Alire is VSS.Regular_Expressions.To_Regular_Expression ("export ([^=]+)=""([^\n]+)"""); - Anchored : constant VSS.Regular_Expressions.Match_Options := - (VSS.Regular_Expressions.Anchored_Match => True); - - List : array (1 .. 2) of aliased Process_Listener; Lines : VSS.String_Vectors.Virtual_String_Vector; - Text : VSS.Strings.Virtual_String; - Decoder : VSS.Strings.Converters.Decoders.Virtual_String_Decoder; begin Project.Clear; Has_Alire := ALR /= null; @@ -116,67 +110,14 @@ package body LSP.Ada_Handlers.Alire is return; end if; - Start_Alire (List (1), ALR.all, "--non-interactive", "show", Root); - Start_Alire (List (2), ALR.all, "--non-interactive", "printenv", Root); + Start_Alire (ALR.all, "--non-interactive", "show", Root, Error, Lines); - loop - Spawn.Processes.Monitor_Loop (0.1); - - exit when - (for all Item of List => Item.Process.Status = Spawn.Not_Running); - end loop; - - Decoder.Initialize ("utf-8"); - GNAT.OS_Lib.Free (ALR); - - -- Decode output and check errors - for Item of List loop - Decoder.Reset_State; - Item.Text := Decoder.Decode (Item.Stdout); - - if Item.Process.Exit_Status /= Spawn.Normal - or else Item.Process.Exit_Code /= 0 - or else Decoder.Has_Error - or else Item.Error /= 0 - then - Error := "'alr"; - - for Arg of Item.Process.Arguments loop - Error.Append (" "); - Error.Append (VSS.Strings.Conversions.To_Virtual_String (Arg)); - end loop; - - Error.Append ("' failed:"); - Error.Append (VSS.Characters.Latin.Line_Feed); - - if Decoder.Has_Error then - Error.Append (Decoder.Error_Message); - else - Error.Append (Item.Text); - end if; - - Error.Append (VSS.Characters.Latin.Line_Feed); - Decoder.Reset_State; - Text := Decoder.Decode (Item.Stderr); - - if Decoder.Has_Error then - Error.Append (Decoder.Error_Message); - else - Error.Append (Text); - end if; - - if Item.Error /= 0 then - Error.Append - (VSS.Strings.Conversions.To_Virtual_String - (GNAT.OS_Lib.Errno_Message (Item.Error))); - end if; - - return; - end if; - end loop; + if not Error.Is_Empty then + GNAT.OS_Lib.Free (ALR); + return; + end if; -- Find project file in `alr show` output - Lines := List (1).Text.Split_Lines; declare First : constant VSS.Strings.Virtual_String := Lines (1); @@ -202,8 +143,18 @@ package body LSP.Ada_Handlers.Alire is end; end loop; + if Project.Is_Empty then + Error.Append ("No project file is found by alire"); + end if; + + -- Find variables in `alr printenv` output + + Start_Alire + (ALR.all, "--non-interactive", "printenv", Root, Error, Lines); + + GNAT.OS_Lib.Free (ALR); + -- Find variables in `alr printenv` output - Lines := List (2).Text.Split_Lines; for Line of Lines loop declare @@ -219,10 +170,6 @@ package body LSP.Ada_Handlers.Alire is end if; end; end loop; - - if Project.Is_Empty then - Error.Append ("No project file is found by alire"); - end if; end Run_Alire; --------------- @@ -235,33 +182,130 @@ package body LSP.Ada_Handlers.Alire is Error : out VSS.Strings.Virtual_String; Environment : in out GPR2.Environment.Object) is - Ignore : VSS.Strings.Virtual_String; + use type GNAT.OS_Lib.String_Access; + + ALR : GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Locate_Exec_On_Path ("alr"); + + Export_Pattern : constant VSS.Regular_Expressions.Regular_Expression := + VSS.Regular_Expressions.To_Regular_Expression + ("export ([^=]+)=""([^\n]+)"""); + + Lines : VSS.String_Vectors.Virtual_String_Vector; begin - -- TODO: optimization: don't run second alire process - Run_Alire (Root, Has_Alire, Error, Ignore, Environment); + Has_Alire := ALR /= null; + + if ALR = null then + Error := "No alr in the PATH"; + return; + end if; + + Start_Alire + (ALR.all, "--non-interactive", "printenv", Root, Error, Lines); + + GNAT.OS_Lib.Free (ALR); + + -- Find variables in `alr printenv` output + + for Line of Lines loop + declare + Match : constant VSS.Regular_Expressions.Regular_Expression_Match + := Export_Pattern.Match (Line, Anchored); + begin + if Match.Has_Match then + Environment.Insert + (Key => VSS.Strings.Conversions.To_UTF_8_String + (Match.Captured (1)), + Value => VSS.Strings.Conversions.To_UTF_8_String + (Match.Captured (2))); + end if; + end; + end loop; end Run_Alire; - ------------------- - -- Spawn_Process -- - ------------------- + ----------------- + -- Start_Alire -- + ----------------- procedure Start_Alire - (Listener : in out Process_Listener'Class; - ALR : String; + (ALR : String; Option_1 : String; Option_2 : String; - Root : String) + Root : String; + Error : out VSS.Strings.Virtual_String; + Lines : out VSS.String_Vectors.Virtual_String_Vector) is - Process : Spawn.Processes.Process renames Listener.Process; - Options : Spawn.String_Vectors.UTF_8_String_Vector; + use type Spawn.Process_Exit_Code; + use type Spawn.Process_Exit_Status; + use type Spawn.Process_Status; + + Item : aliased Process_Listener; + Process : Spawn.Processes.Process renames Item.Process; + Options : Spawn.String_Vectors.UTF_8_String_Vector; + Decoder : VSS.Strings.Converters.Decoders.Virtual_String_Decoder; + Text : VSS.Strings.Virtual_String; begin Options.Append (Option_1); Options.Append (Option_2); Process.Set_Arguments (Options); Process.Set_Working_Directory (Root); Process.Set_Program (ALR); - Process.Set_Listener (Listener'Unchecked_Access); + Process.Set_Listener (Item'Unchecked_Access); Process.Start; + + loop + Spawn.Processes.Monitor_Loop (0.1); + + exit when Item.Process.Status = Spawn.Not_Running; + end loop; + + Decoder.Initialize ("utf-8"); + + -- Decode output and check errors + Decoder.Reset_State; + Item.Text := Decoder.Decode (Item.Stdout); + + if Item.Process.Exit_Status = Spawn.Normal + and then Item.Process.Exit_Code = 0 + and then not Decoder.Has_Error + and then Item.Error = 0 + then + + Lines := Item.Text.Split_Lines; + + else + Error := "'alr"; + + for Arg of Item.Process.Arguments loop + Error.Append (" "); + Error.Append (VSS.Strings.Conversions.To_Virtual_String (Arg)); + end loop; + + Error.Append ("' failed:"); + Error.Append (VSS.Characters.Latin.Line_Feed); + + if Decoder.Has_Error then + Error.Append (Decoder.Error_Message); + else + Error.Append (Item.Text); + end if; + + Error.Append (VSS.Characters.Latin.Line_Feed); + Decoder.Reset_State; + Text := Decoder.Decode (Item.Stderr); + + if Decoder.Has_Error then + Error.Append (Decoder.Error_Message); + else + Error.Append (Text); + end if; + + if Item.Error /= 0 then + Error.Append + (VSS.Strings.Conversions.To_Virtual_String + (GNAT.OS_Lib.Errno_Message (Item.Error))); + end if; + end if; end Start_Alire; ------------------------------ From 9811b467754f22b67ee155a9c90a0452b3f453b4 Mon Sep 17 00:00:00 2001 From: Maxim Reznik Date: Tue, 23 Apr 2024 18:47:16 +0300 Subject: [PATCH 2/3] Fix some CONSTRAINT_ERROR (invalid data) for non-initialized local variables. (no-issue-check) --- source/ada/lsp-ada_handlers-call_hierarchy.adb | 3 ++- source/ada/lsp-ada_handlers.adb | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/source/ada/lsp-ada_handlers-call_hierarchy.adb b/source/ada/lsp-ada_handlers-call_hierarchy.adb index 8baf2ea47..2f3993c62 100644 --- a/source/ada/lsp-ada_handlers-call_hierarchy.adb +++ b/source/ada/lsp-ada_handlers-call_hierarchy.adb @@ -313,8 +313,9 @@ package body LSP.Ada_Handlers.Call_Hierarchy is end if; end Callback; - Ignore : Libadalang.Common.Ref_Result_Kind; Cursor : Laltools.Common.References_By_Subprogram.Cursor; + Ignore : Libadalang.Common.Ref_Result_Kind := + Libadalang.Common.No_Ref; begin Laltools.Call_Hierarchy.Find_Outgoing_Calls diff --git a/source/ada/lsp-ada_handlers.adb b/source/ada/lsp-ada_handlers.adb index a46640248..d1cf16a0c 100644 --- a/source/ada/lsp-ada_handlers.adb +++ b/source/ada/lsp-ada_handlers.adb @@ -2539,8 +2539,9 @@ package body LSP.Ada_Handlers is Definition : Libadalang.Analysis.Defining_Name; Imprecise : Boolean := False; - Ignore : Libadalang.Common.Ref_Result_Kind; Decl : Libadalang.Analysis.Basic_Decl; + Ignore : Libadalang.Common.Ref_Result_Kind := + Libadalang.Common.No_Ref; begin if Name_Node.Is_Null then From 34d3fa40668363001ff8864f05afb72d8a3ad1c7 Mon Sep 17 00:00:00 2001 From: Maxim Reznik Date: Wed, 24 Apr 2024 15:34:33 +0300 Subject: [PATCH 3/3] Rewrite folding range request as a job Refs #1141 --- source/ada/lsp-ada_documents.adb | 248 ---------------- source/ada/lsp-ada_documents.ads | 10 - source/ada/lsp-ada_driver.adb | 10 + source/ada/lsp-ada_folding_range.adb | 296 +++++++++++++++++++ source/ada/lsp-ada_folding_range.ads | 38 +++ source/ada/lsp-ada_handlers-locations.adb | 18 ++ source/ada/lsp-ada_handlers-locations.ads | 6 + source/ada/lsp-ada_handlers.adb | 47 +-- source/ada/lsp-ada_handlers.ads | 12 +- source/ada/lsp-ada_highlighters.adb | 2 +- source/ada/lsp-ada_job_contexts.ads | 7 + source/lsp_3.17/lsp-constants.ads | 9 + testsuite/ada_lsp/SA22-032.folding/test.json | 5 - 13 files changed, 399 insertions(+), 309 deletions(-) create mode 100644 source/ada/lsp-ada_folding_range.adb create mode 100644 source/ada/lsp-ada_folding_range.ads diff --git a/source/ada/lsp-ada_documents.adb b/source/ada/lsp-ada_documents.adb index 8301e6d4a..281be4957 100644 --- a/source/ada/lsp-ada_documents.adb +++ b/source/ada/lsp-ada_documents.adb @@ -805,254 +805,6 @@ package body LSP.Ada_Documents is end if; end Get_Errors; - ------------------------ - -- Get_Folding_Blocks -- - ------------------------ - - procedure Get_Folding_Blocks - (Self : Document; - Context : LSP.Ada_Contexts.Context; - Lines_Only : Boolean; - Comments : Boolean; - Canceled : access function return Boolean; - Result : out LSP.Structures.FoldingRange_Vector) - is - use Libadalang.Common; - use Libadalang.Analysis; - - Location : LSP.Structures.Location; - foldingRange : LSP.Structures.FoldingRange; - Have_With : Boolean := False; - - function Parse (Node : Ada_Node'Class) return Visit_Status; - -- Includes Node location to the result if the node has "proper" kind - - procedure Store_Span (Span : LSP.Structures.A_Range); - -- Include Span to the result . - - ----------- - -- Parse -- - ----------- - - function Parse (Node : Ada_Node'Class) return Visit_Status - is - - procedure Store_With_Block; - -- Store folding for with/use clauses as one folding block - - ---------------------- - -- Store_With_Block -- - ---------------------- - - procedure Store_With_Block is - begin - if not Have_With then - return; - end if; - - if foldingRange.startLine /= foldingRange.endLine then - Result.Append (foldingRange); - end if; - - Have_With := False; - end Store_With_Block; - - Result : Visit_Status := Into; - begin - if Canceled.all then - return Stop; - end if; - --- Cat_Namespace, --- Cat_Constructor, --- Cat_Destructor, --- Cat_Structure, --- Cat_Case_Inside_Record, --- Cat_Union, --- Cat_Custom - - case Node.Kind is - when Ada_Package_Decl | - Ada_Generic_Formal_Package | - Ada_Package_Body | --- Cat_Package - - Ada_Type_Decl | - - Ada_Classwide_Type_Decl | --- Cat_Class - - Ada_Protected_Type_Decl | --- Cat_Protected - - Ada_Task_Type_Decl | - Ada_Single_Task_Type_Decl | --- Cat_Task - - Ada_Subp_Decl | - Ada_Subp_Body | - Ada_Generic_Formal_Subp_Decl | - Ada_Abstract_Subp_Decl | - Ada_Abstract_Formal_Subp_Decl | - Ada_Concrete_Formal_Subp_Decl | - Ada_Generic_Subp_Internal | - Ada_Null_Subp_Decl | - Ada_Subp_Renaming_Decl | - Ada_Subp_Body_Stub | - Ada_Generic_Subp_Decl | - Ada_Generic_Subp_Instantiation | - Ada_Generic_Subp_Renaming_Decl | - Ada_Subp_Kind_Function | - Ada_Subp_Kind_Procedure | - Ada_Access_To_Subp_Def | --- Cat_Procedure --- Cat_Function --- Cat_Method - - Ada_Case_Stmt | --- Cat_Case_Statement - - Ada_If_Stmt | --- Cat_If_Statement - - Ada_For_Loop_Stmt | - Ada_While_Loop_Stmt | --- Cat_Loop_Statement - - Ada_Begin_Block | - Ada_Decl_Block | --- Cat_Declare_Block --- Cat_Simple_Block - --- Ada_Return_Stmt | --- Ada_Extended_Return_Stmt | - Ada_Extended_Return_Stmt_Object_Decl | --- Cat_Return_Block - - Ada_Select_Stmt | --- Cat_Select_Statement - - Ada_Entry_Body | --- Cat_Entry - - Ada_Exception_Handler | --- Cat_Exception_Handler - - Ada_Pragma_Node_List | - Ada_Pragma_Argument_Assoc | - Ada_Pragma_Node | --- Cat_Pragma - - Ada_Aspect_Spec => --- Cat_Aspect - - Store_With_Block; - - foldingRange.kind := - (Is_Set => True, Value => LSP.Enumerations.Region); - - Location := Self.To_LSP_Location (Node.Sloc_Range); - Store_Span (Location.a_range); - - when Ada_With_Clause | - Ada_Use_Package_Clause | - Ada_Use_Type_Clause => - - Location := Self.To_LSP_Location (Node.Sloc_Range); - - if not Have_With then - Have_With := True; - - foldingRange.kind := - (Is_Set => True, Value => LSP.Enumerations.Imports); - - foldingRange.startLine := Location.a_range.start.line; - end if; - - foldingRange.endLine := Location.a_range.an_end.line; - - -- Do not step into with/use clause - Result := Over; - - when others => - Store_With_Block; - end case; - - return Result; - end Parse; - - ---------------- - -- Store_Span -- - ---------------- - - procedure Store_Span (Span : LSP.Structures.A_Range) is - begin - if not Lines_Only - or else Span.start.line /= Span.an_end.line - then - foldingRange.startLine := Span.start.line; - foldingRange.endLine := Span.an_end.line; - - if not Lines_Only then - foldingRange.startCharacter := - (Is_Set => True, - Value => Span.start.character); - - foldingRange.startCharacter := - (Is_Set => True, - Value => Span.an_end.character); - end if; - - Result.Append (foldingRange); - end if; - end Store_Span; - - Token : Token_Reference; - Span : LSP.Structures.A_Range; - Root : constant Ada_Node'Class := Self.Unit (Context).Root; - - begin - if not Root.Is_Null then - Traverse (Root, Parse'Access); - end if; - - if not Comments then - -- do not process comments - return; - end if; - - -- Looking for comments - foldingRange.kind := (Is_Set => False); - Token := First_Token (Self.Unit (Context)); - - while Token /= No_Token - and then not Canceled.all - loop - case Kind (Data (Token)) is - when Ada_Comment => - if not foldingRange.kind.Is_Set then - foldingRange.kind := - (Is_Set => True, Value => LSP.Enumerations.Comment); - Span := Self.To_A_Range (Sloc_Range (Data (Token))); - else - Span.an_end := - Self.To_A_Range (Sloc_Range (Data (Token))).an_end; - end if; - - when Ada_Whitespace => - null; - - when others => - if foldingRange.kind.Is_Set then - Store_Span (Span); - foldingRange.kind := (Is_Set => False); - end if; - end case; - - Token := Next (Token); - end loop; - end Get_Folding_Blocks; - --------------------------- -- Get_Formatting_Region -- --------------------------- diff --git a/source/ada/lsp-ada_documents.ads b/source/ada/lsp-ada_documents.ads index ec0d34c0d..f06db53b6 100644 --- a/source/ada/lsp-ada_documents.ads +++ b/source/ada/lsp-ada_documents.ads @@ -160,16 +160,6 @@ package LSP.Ada_Documents is Result : in out LSP.Ada_Completions.Completion_Maps.Map); -- See Contexts.Get_Any_Symbol - procedure Get_Folding_Blocks - (Self : Document; - Context : LSP.Ada_Contexts.Context; - Lines_Only : Boolean; - Comments : Boolean; - Canceled : access function return Boolean; - Result : out LSP.Structures.FoldingRange_Vector); - -- Populate Result with code folding blocks in the document. If Lines_Only - -- is True does not return characters positions in lines. - function Get_Formatting_Region (Self : Document; Context : LSP.Ada_Contexts.Context; diff --git a/source/ada/lsp-ada_driver.adb b/source/ada/lsp-ada_driver.adb index 1c64f7481..a21b8cc87 100644 --- a/source/ada/lsp-ada_driver.adb +++ b/source/ada/lsp-ada_driver.adb @@ -43,6 +43,7 @@ with LSP.Ada_Declaration; with LSP.Ada_Document_Symbol; with LSP.Ada_Did_Change_Configurations; with LSP.Ada_Did_Change_Document; +with LSP.Ada_Folding_Range; with LSP.Ada_Hover; with LSP.Ada_References; with LSP.Ada_Handlers; @@ -84,6 +85,7 @@ with LSP.Server_Notifications.DidChangeConfiguration; with LSP.Server_Requests.Definition; with LSP.Server_Requests.Declaration; with LSP.Server_Requests.DocumentSymbol; +with LSP.Server_Requests.FoldingRange; with LSP.Server_Requests.Hover; with LSP.Server_Requests.References; with LSP.Server_Requests.Tokens_Full; @@ -211,6 +213,10 @@ procedure LSP.Ada_Driver is LSP.Ada_Document_Symbol.Ada_Document_Symbol_Handler (Ada_Handler'Unchecked_Access); + Ada_Folding_Range_Handler : aliased + LSP.Ada_Folding_Range.Ada_Folding_Range_Handler + (Ada_Handler'Unchecked_Access); + Ada_Tokens_Full_Handler : aliased LSP.Ada_Tokens_Full.Ada_Tokens_Full_Handler (Ada_Handler'Unchecked_Access); @@ -443,6 +449,10 @@ begin (LSP.Server_Requests.DocumentSymbol.Request'Tag, Ada_Document_Symbol_Handler'Unchecked_Access); + Server.Register_Handler + (LSP.Server_Requests.FoldingRange.Request'Tag, + Ada_Folding_Range_Handler'Unchecked_Access); + Server.Register_Handler (LSP.Server_Requests.Tokens_Full.Request'Tag, Ada_Tokens_Full_Handler'Unchecked_Access); diff --git a/source/ada/lsp-ada_folding_range.adb b/source/ada/lsp-ada_folding_range.adb new file mode 100644 index 000000000..b847d2b05 --- /dev/null +++ b/source/ada/lsp-ada_folding_range.adb @@ -0,0 +1,296 @@ +------------------------------------------------------------------------------ +-- 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.Common; +with Libadalang.Iterators; + +with VSS.Strings; + +with LSP.Ada_Context_Sets; +with LSP.Client_Message_Receivers; +with LSP.Constants; +with LSP.Server_Request_Jobs; +with LSP.Server_Requests.FoldingRange; +with LSP.Structures; + +package body LSP.Ada_Folding_Range 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 Folding_Range_Job + (Parent : not null access constant Ada_Folding_Range_Handler) is limited + new LSP.Server_Request_Jobs.Server_Request_Job + (Priority => LSP.Server_Jobs.Low) + with record + Lines_Only : Boolean; + Unit : Libadalang.Analysis.Analysis_Unit; + Cursor : Traverse_Iterator_Access; + Response : LSP.Structures.FoldingRange_Vector; + end record; + + overriding procedure Execute_Request + (Self : in out Folding_Range_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status); + + procedure Append_Comments (Self : in out Folding_Range_Job'Class); + + procedure Append_Node + (Self : in out Folding_Range_Job'Class; + Node : Libadalang.Analysis.Ada_Node); + + procedure Append_Span + (Self : in out Folding_Range_Job'Class; + Span : LSP.Structures.A_Range; + Kind : LSP.Structures.FoldingRangeKind_Optional); + + --------------------- + -- Append_Comments -- + --------------------- + + procedure Append_Comments (Self : in out Folding_Range_Job'Class) is + use Libadalang.Common; + + Token : Token_Reference := Libadalang.Analysis.First_Token (Self.Unit); + Item : LSP.Structures.A_Range_Optional; + -- Range of consecutive comments + begin + while Token /= No_Token loop + case Kind (Data (Token)) is + when Ada_Comment => + declare + Span : constant LSP.Structures.A_Range := + Self.Parent.Context.To_LSP_Range (Self.Unit, Token); + begin + if Item.Is_Set then + Item.Value.an_end := Span.an_end; + else + Item := (Is_Set => True, Value => Span); + end if; + end; + + when Ada_Whitespace => + null; + + when others => + if Item.Is_Set then + Self.Append_Span (Item.Value, LSP.Constants.Comment); + Item := (Is_Set => False); + end if; + end case; + + Token := Next (Token); + end loop; + end Append_Comments; + + ----------------- + -- Append_Node -- + ----------------- + + procedure Append_Node + (Self : in out Folding_Range_Job'Class; + Node : Libadalang.Analysis.Ada_Node) + is + use Libadalang.Common; + begin + -- Skip Ada_Node_List without with clauses + case Node.Kind is + when Ada_Ada_Node_List => + if (for all Item of Node.As_Ada_Node_List => + Item.Kind /= Ada_With_Clause) + then + return; + end if; + when others => + null; + end case; + + case Node.Kind is + when Ada_Ada_Node_List | + Ada_Package_Decl | + Ada_Generic_Formal_Package | + Ada_Package_Body | + Ada_Type_Decl | + Ada_Classwide_Type_Decl | + Ada_Protected_Type_Decl | + Ada_Task_Type_Decl | + Ada_Single_Task_Type_Decl | + Ada_Subp_Decl | + Ada_Subp_Body | + Ada_Generic_Formal_Subp_Decl | + Ada_Abstract_Subp_Decl | + Ada_Abstract_Formal_Subp_Decl | + Ada_Concrete_Formal_Subp_Decl | + Ada_Generic_Subp_Internal | + Ada_Null_Subp_Decl | + Ada_Subp_Renaming_Decl | + Ada_Subp_Body_Stub | + Ada_Generic_Subp_Decl | + Ada_Generic_Subp_Instantiation | + Ada_Generic_Subp_Renaming_Decl | + Ada_Subp_Kind_Function | + Ada_Subp_Kind_Procedure | + Ada_Access_To_Subp_Def | + Ada_Case_Stmt | + Ada_If_Stmt | + Ada_For_Loop_Stmt | + Ada_While_Loop_Stmt | + Ada_Begin_Block | + Ada_Decl_Block | + Ada_Extended_Return_Stmt_Object_Decl | + Ada_Select_Stmt | + Ada_Entry_Body | + Ada_Exception_Handler | + Ada_Pragma_Node_List | + Ada_Pragma_Argument_Assoc | + Ada_Pragma_Node | + Ada_Aspect_Spec => + + declare + Location : constant LSP.Structures.Location := + Self.Parent.Context.To_LSP_Location (Node); + + Span : LSP.Structures.A_Range renames Location.a_range; + + Kind : constant LSP.Structures.FoldingRangeKind_Optional := + (if Node.Kind = Ada_Ada_Node_List then LSP.Constants.Imports + else LSP.Constants.Region); + + begin + Self.Append_Span (Span, Kind); + end; + when others => + null; + end case; + end Append_Node; + + ----------------- + -- Append_Span -- + ----------------- + + procedure Append_Span + (Self : in out Folding_Range_Job'Class; + Span : LSP.Structures.A_Range; + Kind : LSP.Structures.FoldingRangeKind_Optional) + is + function Get_Column (Column : Natural) + return LSP.Structures.Natural_Optional is + (if Self.Lines_Only then (Is_Set => False) + else (Is_Set => True, Value => Column)); + + begin + if not Self.Lines_Only + or else Span.start.line /= Span.an_end.line + then + declare + Item : constant LSP.Structures.FoldingRange := + (startLine => Span.start.line, + startCharacter => Get_Column (Span.start.character), + endLine => Span.an_end.line, + endCharacter => Get_Column (Span.an_end.character), + kind => Kind, + collapsedText => VSS.Strings.Empty_Virtual_String); + begin + Self.Response.Append (Item); + end; + end if; + end Append_Span; + + ---------------- + -- Create_Job -- + ---------------- + + overriding function Create_Job + (Self : Ada_Folding_Range_Handler; + Message : LSP.Server_Messages.Server_Message_Access) + return LSP.Server_Jobs.Server_Job_Access + is + Value : LSP.Structures.FoldingRangeParams + renames LSP.Server_Requests.FoldingRange.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 LSP.Server_Jobs.Server_Job_Access := + new Folding_Range_Job' + (Parent => Self'Unchecked_Access, + Request => LSP.Server_Request_Jobs.Request_Access (Message), + Unit => Unit, + Cursor => new Libadalang.Iterators.Traverse_Iterator'Class' + (Libadalang.Iterators.Traverse (Unit.Root)), + Lines_Only => Self.Context.Client.Line_Folding_Only, + Response => <>); + begin + return Job; + end Create_Job; + + --------------------- + -- Execute_Request -- + --------------------- + + overriding procedure Execute_Request + (Self : in out Folding_Range_Job; + Client : + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; + Status : out LSP.Server_Jobs.Execution_Status) + is + Node : Libadalang.Analysis.Ada_Node; + begin + Status := LSP.Server_Jobs.Continue; + + for J in 1 .. 300 loop + if Self.Cursor.Next (Node) then + Self.Append_Node (Node); + + else + declare + Message : LSP.Server_Requests.FoldingRange.Request + renames LSP.Server_Requests.FoldingRange.Request + (Self.Message.all); + begin + if Self.Parent.Context.Get_Configuration.Folding_Comments then + Self.Append_Comments; + end if; + + Client.On_FoldingRange_Response (Message.Id, Self.Response); + + Free (Self.Cursor); + Status := LSP.Server_Jobs.Done; + + return; + end; + end if; + end loop; + end Execute_Request; +end LSP.Ada_Folding_Range; diff --git a/source/ada/lsp-ada_folding_range.ads b/source/ada/lsp-ada_folding_range.ads new file mode 100644 index 000000000..51a168a1c --- /dev/null +++ b/source/ada/lsp-ada_folding_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/foldingRange +-- requests. + +with LSP.Ada_Job_Contexts; +with LSP.Server_Jobs; +with LSP.Server_Message_Handlers; +with LSP.Server_Messages; + +package LSP.Ada_Folding_Range is + + type Ada_Folding_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_Folding_Range_Handler; + Message : LSP.Server_Messages.Server_Message_Access) + return LSP.Server_Jobs.Server_Job_Access; + +end LSP.Ada_Folding_Range; diff --git a/source/ada/lsp-ada_handlers-locations.adb b/source/ada/lsp-ada_handlers-locations.adb index 75badf428..deb3ba125 100644 --- a/source/ada/lsp-ada_handlers-locations.adb +++ b/source/ada/lsp-ada_handlers-locations.adb @@ -303,6 +303,24 @@ package body LSP.Ada_Handlers.Locations is end if; end To_LSP_Location; + ------------------ + -- To_LSP_Range -- + ------------------ + + function To_LSP_Range + (Self : in out Message_Handler'Class; + Unit : Libadalang.Analysis.Analysis_Unit; + Token : Libadalang.Common.Token_Reference) + return LSP.Structures.A_Range + is + pragma Unreferenced (Self); + + Sloc : constant Langkit_Support.Slocs.Source_Location_Range := + Libadalang.Common.Sloc_Range (Libadalang.Common.Data (Token)); + begin + return To_LSP_Range (Unit, Sloc); + end To_LSP_Range; + --------------------- -- To_LSP_Location -- --------------------- diff --git a/source/ada/lsp-ada_handlers-locations.ads b/source/ada/lsp-ada_handlers-locations.ads index c921a6fd7..ca16c660f 100644 --- a/source/ada/lsp-ada_handlers-locations.ads +++ b/source/ada/lsp-ada_handlers-locations.ads @@ -45,6 +45,12 @@ package LSP.Ada_Handlers.Locations is Kinds : LSP.Structures.AlsReferenceKind_Set := LSP.Constants.Empty) return LSP.Structures.Location; + function To_LSP_Range + (Self : in out Message_Handler'Class; + Unit : Libadalang.Analysis.Analysis_Unit; + Token : Libadalang.Common.Token_Reference) + return LSP.Structures.A_Range; + function Get_Node_At (Self : in out Message_Handler'Class; Context : LSP.Ada_Contexts.Context; diff --git a/source/ada/lsp-ada_handlers.adb b/source/ada/lsp-ada_handlers.adb index d1cf16a0c..c19f9f60c 100644 --- a/source/ada/lsp-ada_handlers.adb +++ b/source/ada/lsp-ada_handlers.adb @@ -31,8 +31,6 @@ with VSS.Strings.Templates; with VSS.String_Vectors; with VSS.JSON.Streams; -with Libadalang.Common; - with Laltools.Common; with Laltools.Partial_GNATPP; @@ -152,6 +150,13 @@ package body LSP.Ada_Handlers is return LSP.Structures.Location is (LSP.Ada_Handlers.Locations.To_LSP_Location (Self, Node)); + overriding function To_LSP_Range + (Self : in out Message_Handler; + Unit : Libadalang.Analysis.Analysis_Unit; + Token : Libadalang.Common.Token_Reference) + return LSP.Structures.A_Range is + (LSP.Ada_Handlers.Locations.To_LSP_Range (Self, Unit, Token)); + overriding function Get_Node_At (Self : in out Message_Handler; Context : LSP.Ada_Contexts.Context; @@ -2396,44 +2401,6 @@ package body LSP.Ada_Handlers is LSP.Servers.Server'Class (Self.Sender.all).Stop; end On_Exits_Notification; - ----------------------------- - -- On_FoldingRange_Request -- - ----------------------------- - - overriding procedure On_FoldingRange_Request - (Self : in out Message_Handler; - Id : LSP.Structures.Integer_Or_Virtual_String; - Value : LSP.Structures.FoldingRangeParams) - is - use type LSP.Ada_Documents.Document_Access; - - Context : constant LSP.Ada_Context_Sets.Context_Access := - Self.Contexts.Get_Best_Context (Value.textDocument.uri); - Document : constant LSP.Ada_Documents.Document_Access := - Get_Open_Document (Self, Value.textDocument.uri); - Response : LSP.Structures.FoldingRange_Vector_Or_Null; - - begin - if Document /= null then - Document.Get_Folding_Blocks - (Context.all, - Self.Client.Line_Folding_Only, - Self.Configuration.Folding_Comments, - Self.Is_Canceled, - Response); - - if Self.Is_Canceled.all then - Response.Clear; - end if; - Self.Sender.On_FoldingRange_Response (Id, Response); - - else - Self.Sender.On_Error_Response - (Id, (code => LSP.Enumerations.InternalError, - message => "Document is not opened")); - end if; - end On_FoldingRange_Request; - --------------------------- -- On_Formatting_Request -- --------------------------- diff --git a/source/ada/lsp-ada_handlers.ads b/source/ada/lsp-ada_handlers.ads index 7fe158463..d461b38bf 100644 --- a/source/ada/lsp-ada_handlers.ads +++ b/source/ada/lsp-ada_handlers.ads @@ -29,6 +29,7 @@ with GPR2.Log; with GPR2.Project.Tree; with Libadalang.Analysis; +with Libadalang.Common; with VSS.Strings.Conversions; @@ -344,11 +345,6 @@ private Id : LSP.Structures.Integer_Or_Virtual_String; Value : LSP.Structures.RenameParams); - overriding procedure On_FoldingRange_Request - (Self : in out Message_Handler; - Id : LSP.Structures.Integer_Or_Virtual_String; - Value : LSP.Structures.FoldingRangeParams); - overriding procedure On_Formatting_Request (Self : in out Message_Handler; Id : LSP.Structures.Integer_Or_Virtual_String; @@ -524,6 +520,12 @@ private Node : Libadalang.Analysis.Ada_Node'Class) return LSP.Structures.Location; + overriding function To_LSP_Range + (Self : in out Message_Handler; + Unit : Libadalang.Analysis.Analysis_Unit; + Token : Libadalang.Common.Token_Reference) + return LSP.Structures.A_Range; + overriding procedure Append_Location (Self : in out Message_Handler; Result : in out LSP.Structures.Location_Vector; diff --git a/source/ada/lsp-ada_highlighters.adb b/source/ada/lsp-ada_highlighters.adb index 9c7b2882b..b9c610a4f 100644 --- a/source/ada/lsp-ada_highlighters.adb +++ b/source/ada/lsp-ada_highlighters.adb @@ -377,7 +377,7 @@ package body LSP.Ada_Highlighters is Start : constant Langkit_Support.Slocs.Source_Location := Langkit_Support.Slocs.Start_Sloc (Sloc_Range); - Map : constant array (Libadalang.Common.Token_Kind) of + Map : constant array (Libadalang.Common.Token_Kind) of LSP.Enumerations.SemanticTokenTypes := (Ada_All .. Ada_Xor | Ada_With => keyword, Ada_Par_Close .. Ada_Target => operator, diff --git a/source/ada/lsp-ada_job_contexts.ads b/source/ada/lsp-ada_job_contexts.ads index 144ff0c2c..3f63a33c1 100644 --- a/source/ada/lsp-ada_job_contexts.ads +++ b/source/ada/lsp-ada_job_contexts.ads @@ -24,6 +24,7 @@ with GNATCOLL.Traces; with GNATCOLL.VFS; with Libadalang.Analysis; +with Libadalang.Common; with Laltools.Common; @@ -124,6 +125,12 @@ package LSP.Ada_Job_Contexts is Node : Libadalang.Analysis.Ada_Node'Class) return LSP.Structures.Location is abstract; + function To_LSP_Range + (Self : in out Ada_Job_Context; + Unit : Libadalang.Analysis.Analysis_Unit; + Token : Libadalang.Common.Token_Reference) + return LSP.Structures.A_Range is abstract; + procedure Append_Location (Self : in out Ada_Job_Context; Result : in out LSP.Structures.Location_Vector; diff --git a/source/lsp_3.17/lsp-constants.ads b/source/lsp_3.17/lsp-constants.ads index fa4193c55..4eef395a7 100644 --- a/source/lsp_3.17/lsp-constants.ads +++ b/source/lsp_3.17/lsp-constants.ads @@ -154,4 +154,13 @@ package LSP.Constants is return LSP.Structures.FileOperationPatternOptions_Optional is (Is_Set => True, Value => (ignoreCase => True)); + function Region return LSP.Structures.FoldingRangeKind_Optional is + (Is_Set => True, Value => LSP.Enumerations.Region); + + function Imports return LSP.Structures.FoldingRangeKind_Optional is + (Is_Set => True, Value => LSP.Enumerations.Imports); + + function Comment return LSP.Structures.FoldingRangeKind_Optional is + (Is_Set => True, Value => LSP.Enumerations.Comment); + end LSP.Constants; diff --git a/testsuite/ada_lsp/SA22-032.folding/test.json b/testsuite/ada_lsp/SA22-032.folding/test.json index de913e1d1..d9f0039f8 100644 --- a/testsuite/ada_lsp/SA22-032.folding/test.json +++ b/testsuite/ada_lsp/SA22-032.folding/test.json @@ -115,11 +115,6 @@ "startLine": 4, "kind": "region" }, - { - "startLine": 5, - "endLine": 6, - "kind": "imports" - }, { "startLine": 11, "endLine": 15,