|
| 1 | +------------------------------------------------------------------------------ |
| 2 | +-- Language Server Protocol -- |
| 3 | +-- -- |
| 4 | +-- Copyright (C) 2024, AdaCore -- |
| 5 | +-- -- |
| 6 | +-- This is free software; you can redistribute it and/or modify it under -- |
| 7 | +-- terms of the GNU General Public License as published by the Free Soft- -- |
| 8 | +-- ware Foundation; either version 3, or (at your option) any later ver- -- |
| 9 | +-- sion. This software is distributed in the hope that it will be useful, -- |
| 10 | +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- |
| 11 | +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- |
| 12 | +-- License for more details. You should have received a copy of the GNU -- |
| 13 | +-- General Public License distributed with this software; see file -- |
| 14 | +-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- |
| 15 | +-- of the license. -- |
| 16 | +------------------------------------------------------------------------------ |
| 17 | + |
| 18 | +with Ada.Tags.Generic_Dispatching_Constructor; |
| 19 | +with Ada.Unchecked_Deallocation; |
| 20 | + |
| 21 | +with VSS.Strings.Conversions; |
| 22 | + |
| 23 | +with LSP.Ada_Commands; |
| 24 | +with LSP.Ada_Handlers; |
| 25 | +with LSP.Ada_Request_Jobs; |
| 26 | +with LSP.Client_Message_Receivers; |
| 27 | +with LSP.Enumerations; |
| 28 | +with LSP.Errors; |
| 29 | +with LSP.Server_Requests.ExecuteCommand; |
| 30 | +with LSP.Structures; |
| 31 | + |
| 32 | +package body LSP.Ada_Execute_Command is |
| 33 | + |
| 34 | + type Command_Access is access LSP.Ada_Commands.Command'Class; |
| 35 | + |
| 36 | + procedure Free is new Ada.Unchecked_Deallocation |
| 37 | + (LSP.Ada_Commands.Command'Class, Command_Access); |
| 38 | + |
| 39 | + type Ada_Execute_Command_Job |
| 40 | + (Parent : not null access constant Execute_Command_Handler) is limited |
| 41 | + new LSP.Ada_Request_Jobs.Ada_Request_Job (Priority => LSP.Server_Jobs.Low) |
| 42 | + with record |
| 43 | + Command : Command_Access; |
| 44 | + end record; |
| 45 | + |
| 46 | + overriding function Priority |
| 47 | + (Self : Ada_Execute_Command_Job) return LSP.Server_Jobs.Job_Priority is |
| 48 | + (if Self.Request.Canceled then LSP.Server_Jobs.Immediate |
| 49 | + elsif Self.Command = null then LSP.Server_Jobs.Low |
| 50 | + else Self.Command.Priority); |
| 51 | + -- Use command priority when we have a command |
| 52 | + |
| 53 | + overriding procedure Execute_Ada_Request |
| 54 | + (Self : in out Ada_Execute_Command_Job; |
| 55 | + Client : |
| 56 | + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; |
| 57 | + Status : out LSP.Server_Jobs.Execution_Status); |
| 58 | + |
| 59 | + function Create_Command is new Ada.Tags.Generic_Dispatching_Constructor |
| 60 | + (T => LSP.Ada_Commands.Command, |
| 61 | + Parameters => LSP.Structures.LSPAny_Vector, |
| 62 | + Constructor => LSP.Ada_Commands.Create); |
| 63 | + |
| 64 | + ---------------- |
| 65 | + -- Create_Job -- |
| 66 | + ---------------- |
| 67 | + |
| 68 | + overriding function Create_Job |
| 69 | + (Self : Execute_Command_Handler; |
| 70 | + Message : LSP.Server_Messages.Server_Message_Access) |
| 71 | + return LSP.Server_Jobs.Server_Job_Access |
| 72 | + is |
| 73 | + use type Ada.Tags.Tag; |
| 74 | + |
| 75 | + Request : LSP.Server_Requests.ExecuteCommand.Request |
| 76 | + renames LSP.Server_Requests.ExecuteCommand.Request (Message.all); |
| 77 | + |
| 78 | + Params : LSP.Structures.ExecuteCommandParams renames Request.Params; |
| 79 | + |
| 80 | + Tag : constant Ada.Tags.Tag := |
| 81 | + (if Params.command.Is_Empty then Ada.Tags.No_Tag |
| 82 | + else Ada.Tags.Internal_Tag |
| 83 | + (VSS.Strings.Conversions.To_UTF_8_String (Params.command))); |
| 84 | + |
| 85 | + Command : constant Command_Access := |
| 86 | + (if Tag = Ada.Tags.No_Tag then null |
| 87 | + else new LSP.Ada_Commands.Command'Class' |
| 88 | + (Create_Command (Tag, Params.arguments'Unrestricted_Access))); |
| 89 | + |
| 90 | + Result : constant LSP.Server_Jobs.Server_Job_Access := |
| 91 | + new Ada_Execute_Command_Job' |
| 92 | + (Parent => Self'Unchecked_Access, |
| 93 | + Command => Command, |
| 94 | + Request => LSP.Ada_Request_Jobs.Request_Access (Message)); |
| 95 | + begin |
| 96 | + return Result; |
| 97 | + end Create_Job; |
| 98 | + |
| 99 | + ------------------------- |
| 100 | + -- Execute_Ada_Request -- |
| 101 | + ------------------------- |
| 102 | + |
| 103 | + overriding procedure Execute_Ada_Request |
| 104 | + (Self : in out Ada_Execute_Command_Job; |
| 105 | + Client : |
| 106 | + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; |
| 107 | + Status : out LSP.Server_Jobs.Execution_Status) |
| 108 | + is |
| 109 | + |
| 110 | + Handler : constant not null access |
| 111 | + LSP.Ada_Handlers.Message_Handler'Class := |
| 112 | + LSP.Ada_Handlers.Message_Handler'Class |
| 113 | + (Self.Parent.Context.all)'Access; |
| 114 | + |
| 115 | + Message : LSP.Server_Requests.ExecuteCommand.Request |
| 116 | + renames LSP.Server_Requests.ExecuteCommand.Request (Self.Message.all); |
| 117 | + |
| 118 | + Response : LSP.Structures.LSPAny_Or_Null; |
| 119 | + Error : LSP.Errors.ResponseError_Optional; |
| 120 | + |
| 121 | + begin |
| 122 | + Status := LSP.Server_Jobs.Done; |
| 123 | + |
| 124 | + if Self.Command = null then |
| 125 | + Client.On_Error_Response |
| 126 | + (Message.Id, |
| 127 | + (code => LSP.Enumerations.InternalError, |
| 128 | + message => "Unknown command")); |
| 129 | + |
| 130 | + else |
| 131 | + Self.Command.Execute |
| 132 | + (Handler => Handler, |
| 133 | + Response => Response, |
| 134 | + Error => Error); |
| 135 | + |
| 136 | + if Error.Is_Set then |
| 137 | + Client.On_Error_Response (Message.Id, Error.Value); |
| 138 | + else |
| 139 | + Client.On_ExecuteCommand_Response (Message.Id, Response); |
| 140 | + end if; |
| 141 | + |
| 142 | + Free (Self.Command); |
| 143 | + end if; |
| 144 | + end Execute_Ada_Request; |
| 145 | + |
| 146 | +end LSP.Ada_Execute_Command; |
0 commit comments