ada_language_server_22.0.0_ef4bdf41/source/server/lsp-servers.ads

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
------------------------------------------------------------------------------
--                         Language Server Protocol                         --
--                                                                          --
--                     Copyright (C) 2018-2021, 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 a basic LSP server implementation.
--
--  The Server object is initializad with Request and Notification handlers,
--  that actually implements message processing.

with Ada.Streams;
with Ada.Exceptions;

with LSP.Client_Message_Receivers;
with LSP.Client_Notification_Receivers;
with LSP.Message_Loggers;
with LSP.Messages.Client_Requests;
with LSP.Messages;
with LSP.Server_Backends;
with LSP.Server_Notification_Receivers;
with LSP.Server_Request_Handlers;
with LSP.Types;

with GNATCOLL.Traces;

private with Ada.Strings.Unbounded;
private with Ada.Containers.Hashed_Maps;
private with Ada.Containers.Synchronized_Queue_Interfaces;
private with Ada.Containers.Unbounded_Synchronized_Queues;
private with GNAT.Semaphores;
private with System;
private with LSP.Messages.Server_Notifications;
private with LSP.Messages.Server_Requests;

package LSP.Servers is

   type Server is limited
     new LSP.Client_Message_Receivers.Client_Message_Receiver with private;
   --  The representation of LSP server.
   --  Use methods of Client_Message_Receiver to send notifications and
   --  requests to the LSP client.

   procedure Initialize
     (Self   : in out Server;
      Stream : access Ada.Streams.Root_Stream_Type'Class);
   --  Initialize a server by providing input/output Stream.

   procedure Finalize (Self : in out Server);
   --  Clean up memory, file handles, tasks, etc.

   type Uncaught_Exception_Handler is access
     procedure (E : Ada.Exceptions.Exception_Occurrence);

   procedure Run
     (Self         : in out Server;
      Request      : not null
        LSP.Server_Request_Handlers.Server_Request_Handler_Access;
      Notification : not null
        LSP.Server_Notification_Receivers.Server_Notification_Receiver_Access;
      Server       : not null LSP.Server_Backends.Server_Backend_Access;
      On_Error     : not null Uncaught_Exception_Handler;
      Server_Trace : GNATCOLL.Traces.Trace_Handle;
      In_Trace     : GNATCOLL.Traces.Trace_Handle;
      Out_Trace    : GNATCOLL.Traces.Trace_Handle);
   --  Run the server using given Request and Notification handler.
   --  Server_Trace - main trace for the LSP.
   --  In_Trace and Out_Trace - traces that logs all input & output for
   --  debugging purposes. Call On_Error in case of uncaught exceptions.

   procedure Stop (Self : in out Server);
   --  Ask server to stop

   type Message_Access is access all LSP.Messages.Message'Class;

   function Look_Ahead_Message (Self : Server) return Message_Access;
   --  Get next nessage in the queue if any. Only request/notification
   --  handlers are allowed to call this function.

   function Input_Queue_Length (Self : Server) return Natural;
   --  Return number of messages pending in Input_Queue.
   --  For debug purposes only!

   overriding procedure On_Show_Message
     (Self   : access Server;
      Params : LSP.Messages.ShowMessageParams);

   overriding procedure On_Log_Message
     (Self   : access Server;
      Params : LSP.Messages.LogMessageParams);

   overriding procedure On_Publish_Diagnostics
     (Self   : access Server;
      Params : LSP.Messages.PublishDiagnosticsParams);

   overriding function Get_Progress_Type
     (Self  : access Server;
      Token : LSP.Types.LSP_Number_Or_String)
      return LSP.Client_Notification_Receivers.Progress_Value_Kind;

   overriding procedure On_Progress
     (Self   : access Server;
      Params : LSP.Messages.Progress_Params);

   overriding procedure On_Progress_SymbolInformation_Vector
     (Self   : access Server;
      Params : LSP.Messages.Progress_SymbolInformation_Vector);

   overriding procedure On_ShowMessage_Request
     (Self    : access Server;
      Message : LSP.Messages.Client_Requests.ShowMessage_Request);

   overriding procedure On_ShowDocument_Request
     (Self    : access Server;
      Message : LSP.Messages.Client_Requests.ShowDocument_Request);

   overriding procedure On_Workspace_Apply_Edit_Request
     (Self    : access Server;
      Message : LSP.Messages.Client_Requests.Workspace_Apply_Edit_Request);

   overriding procedure On_Workspace_Configuration_Request
     (Self    : access Server;
      Message : LSP.Messages.Client_Requests.Workspace_Configuration_Request);

   overriding procedure On_WorkDoneProgress_Create_Request
     (Self    : access Server;
      Message : LSP.Messages.Client_Requests.WorkDoneProgressCreate_Request);

   overriding procedure On_Workspace_Folders_Request
     (Self    : access Server;
      Message : LSP.Messages.Client_Requests.Workspace_Folders_Request);

   overriding procedure On_RegisterCapability_Request
     (Self    : access Server;
      Message : LSP.Messages.Client_Requests.RegisterCapability_Request);

   overriding procedure On_UnregisterCapability_Request
     (Self    : access Server;
      Message : LSP.Messages.Client_Requests.UnregisterCapability_Request);

   function Has_Pending_Work (Self : Server) return Boolean;
   --  Return True if the server has work in the queue, other than the
   --  notification/request it's currently processing. This should only be
   --  called from the processing task.

private

   -------------------------
   --  Tasking in the ALS --
   -------------------------

   --  The server has 4 tasks:
   --    The input task
   --         This reads input coming from stdin, forms requests, and places
   --         them on the requests queue. It also destroys processed requests.
   --    The processing task:
   --         This is the task where libadalang lives. This task receives
   --         requests from the request queue, processes them, and returns
   --         the responses from them on the output queue.
   --    The output task:
   --         This task reads the responses coming from the output queue,
   --         and writes them to the standard output.
   --    The filesystem monitoring task:
   --         This tasks monitors the filesystem for any changes in source
   --         files
   --
   --  There are next flows of messages:
   --  * Notifications created by Input_Tast are processed and destroyed by
   --    Processing_Task.
   --  * Requests created by Input_Tast, processed by Processing_Task, but
   --    destroyed by Input_Task.
   --  * Messages created by Processing_Task are destroyed by Output_Task.
   --
   --  Because Input_Task controls life time of any request, it is able to
   --  mark it canceled

   type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class;

   type Request_Access is
     access all LSP.Messages.Server_Requests.Server_Request'Class;

   type Notification_Access is
     access all LSP.Messages.Server_Notifications.Server_Notification'Class;

   package Request_Maps is new Ada.Containers.Hashed_Maps
     (Key_Type        => LSP.Types.LSP_Number_Or_String,  --  Request id
      Element_Type    => Request_Access,
      Hash            => LSP.Types.Hash,
      Equivalent_Keys => LSP.Types."=",
      "="             => "=");

   package Message_Queue_Interface is new
     Ada.Containers.Synchronized_Queue_Interfaces
       (Message_Access);

   package Message_Queues is new
     Ada.Containers.Unbounded_Synchronized_Queues
       (Message_Queue_Interface);

   type Input_Queue_Access is access Message_Queues.Queue;
   type Output_Queue_Access is access Message_Queues.Queue;

   Processing_Task_Stack_Size : constant := 32 * 1_024 * 1_024;
   --  Size of the stack for request processing task. Set it to high enough
   --  value to prevent crashes on deep nesting calls inside LAL.

   --  The processing task
   task type Processing_Task_Type
     (Server : access LSP.Servers.Server)
     with Storage_Size => Processing_Task_Stack_Size
   is
      entry Start
        (Request      : not null LSP.Server_Request_Handlers
           .Server_Request_Handler_Access;
         Notification : not null LSP.Server_Notification_Receivers
         .Server_Notification_Receiver_Access;
         Server       : not null LSP.Server_Backends.Server_Backend_Access);
      entry Stop;
      --  Clean shutdown of the task
   end Processing_Task_Type;

   --  The output task
   task type Output_Task_Type
     (Server : access LSP.Servers.Server)
   is
      entry Start;
      --  Start the task. Should be called once.

      entry Stop;
      --  Clean shutdown of the task. Can only be called after Start.
   end Output_Task_Type;

   --  The input task
   task type Input_Task_Type
     (Server : access LSP.Servers.Server)
   is
      entry Start;
      --  Start the task. Should be called once.

      entry Stop;
      --  Clean shutdown of the task. Can only be called after Start.
   end Input_Task_Type;

   ------------
   -- Server --
   ------------

   type Server is limited
     new LSP.Client_Message_Receivers.Client_Message_Receiver with
   record
      Stop          : GNAT.Semaphores.Binary_Semaphore
                          (Initially_Available => False,
                           Ceiling => System.Default_Priority);
      --  Signal to main task to stop server. Released on "exit" message or
      --  on end of input stream.
      Stream        : access Ada.Streams.Root_Stream_Type'Class;
      Last_Request  : LSP.Types.LSP_Number := 1;
      Vector        : Ada.Strings.Unbounded.Unbounded_String;

      --  Queues and tasks used for asynchronous processing, see doc above
      Input_Queue     : Message_Queues.Queue;
      Look_Ahead      : Message_Access;
      --  One message look-ahead buffer for Input_Queue
      Output_Queue    : Message_Queues.Queue;
      Processing_Task : Processing_Task_Type (Server'Unchecked_Access);
      Output_Task     : Output_Task_Type (Server'Unchecked_Access);
      Input_Task      : Input_Task_Type (Server'Unchecked_Access);
      Request_Map     : Request_Maps.Map;
      Destroy_Queue   : Message_Queues.Queue;

      Server_Trace    : GNATCOLL.Traces.Trace_Handle;
      In_Trace        : GNATCOLL.Traces.Trace_Handle;
      Out_Trace       : GNATCOLL.Traces.Trace_Handle;
      Logger          : aliased LSP.Message_Loggers.Message_Logger;
      On_Error        : Uncaught_Exception_Handler;

   end record;

   Unknown_Method : exception;
   --  This exception is raised by message decoder when it's unable to decode
   --  an unknown request
end LSP.Servers;