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-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;
------------------------------
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 9105273de..23a1a6a95 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;
@@ -2395,44 +2400,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,