|
| 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 GNATCOLL.Traces; |
| 19 | +with GNATCOLL.VFS; |
| 20 | + |
| 21 | +with Libadalang.Analysis; |
| 22 | +with Libadalang.Common; |
| 23 | + |
| 24 | +with Laltools.Common; |
| 25 | + |
| 26 | +with LSP.Ada_Context_Sets; |
| 27 | +with LSP.Ada_Handlers.Locations; |
| 28 | +with LSP.Client_Message_Receivers; |
| 29 | +with LSP.Enumerations; |
| 30 | +with LSP.Locations; |
| 31 | +with LSP.Server_Request_Jobs; |
| 32 | +with LSP.Server_Requests.Declaration; |
| 33 | +with LSP.Structures; |
| 34 | + |
| 35 | +package body LSP.Ada_Declaration is |
| 36 | + |
| 37 | + subtype AlsReferenceKind_Array is LSP.Structures.AlsReferenceKind_Set; |
| 38 | + |
| 39 | + function Is_Parent return AlsReferenceKind_Array is |
| 40 | + ([LSP.Enumerations.parent => True, others => False]); |
| 41 | + |
| 42 | + function Is_Child return AlsReferenceKind_Array is |
| 43 | + ([LSP.Enumerations.child => True, others => False]); |
| 44 | + |
| 45 | + type Ada_Declaration_Job |
| 46 | + (Parent : not null access constant Ada_Declaration_Handler) is limited |
| 47 | + new LSP.Server_Request_Jobs.Server_Request_Job |
| 48 | + (Priority => LSP.Server_Jobs.High) |
| 49 | + with record |
| 50 | + Response : LSP.Structures.Location_Vector; |
| 51 | + Filter : LSP.Locations.File_Span_Sets.Set; |
| 52 | + Contexts : LSP.Ada_Context_Sets.Context_Lists.List; |
| 53 | + end record; |
| 54 | + |
| 55 | + type Ada_Declaration_Job_Access is access all Ada_Declaration_Job; |
| 56 | + |
| 57 | + overriding procedure Execute_Request |
| 58 | + (Self : in out Ada_Declaration_Job; |
| 59 | + Client : |
| 60 | + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; |
| 61 | + Status : out LSP.Server_Jobs.Execution_Status); |
| 62 | + |
| 63 | + function "or" |
| 64 | + (Left : |
| 65 | + LSP.Structures.AlsDisplayMethodAncestryOnNavigationPolicy_Optional; |
| 66 | + Right : LSP.Enumerations.AlsDisplayMethodAncestryOnNavigationPolicy) |
| 67 | + return LSP.Enumerations.AlsDisplayMethodAncestryOnNavigationPolicy is |
| 68 | + (if Left.Is_Set then Left.Value else Right); |
| 69 | + |
| 70 | + ---------------- |
| 71 | + -- Create_Job -- |
| 72 | + ---------------- |
| 73 | + |
| 74 | + overriding function Create_Job |
| 75 | + (Self : Ada_Declaration_Handler; |
| 76 | + Message : LSP.Server_Messages.Server_Message_Access) |
| 77 | + return LSP.Server_Jobs.Server_Job_Access |
| 78 | + is |
| 79 | + Value : LSP.Server_Requests.Declaration.Request |
| 80 | + renames LSP.Server_Requests.Declaration.Request |
| 81 | + (Message.all); |
| 82 | + |
| 83 | + File : constant GNATCOLL.VFS.Virtual_File := |
| 84 | + Self.Context.To_File (Value.Params.textDocument.uri); |
| 85 | + |
| 86 | + Result : constant Ada_Declaration_Job_Access := |
| 87 | + new Ada_Declaration_Job' |
| 88 | + (Parent => Self'Unchecked_Access, |
| 89 | + Request => LSP.Server_Request_Jobs.Request_Access (Message), |
| 90 | + others => <>); |
| 91 | + begin |
| 92 | + Result.Contexts := Self.Context.Contexts_For_File (File); |
| 93 | + |
| 94 | + return LSP.Server_Jobs.Server_Job_Access (Result); |
| 95 | + end Create_Job; |
| 96 | + |
| 97 | + --------------------- |
| 98 | + -- Execute_Request -- |
| 99 | + --------------------- |
| 100 | + |
| 101 | + overriding procedure Execute_Request |
| 102 | + (Self : in out Ada_Declaration_Job; |
| 103 | + Client : |
| 104 | + in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class; |
| 105 | + Status : out LSP.Server_Jobs.Execution_Status) |
| 106 | + is |
| 107 | + use type |
| 108 | + LSP.Structures.AlsDisplayMethodAncestryOnNavigationPolicy_Optional; |
| 109 | + |
| 110 | + use all type LSP.Enumerations.AlsDisplayMethodAncestryOnNavigationPolicy; |
| 111 | + |
| 112 | + Message : LSP.Server_Requests.Declaration.Request |
| 113 | + renames LSP.Server_Requests.Declaration.Request (Self.Message.all); |
| 114 | + |
| 115 | + Value : LSP.Structures.DeclarationParams renames Message.Params; |
| 116 | + |
| 117 | + Context : LSP.Ada_Context_Sets.Context_Access; |
| 118 | + |
| 119 | + Display_Method_Policy : constant |
| 120 | + LSP.Enumerations.AlsDisplayMethodAncestryOnNavigationPolicy := |
| 121 | + Value.alsDisplayMethodAncestryOnNavigation |
| 122 | + or |
| 123 | + Self.Parent.Context.Get_Configuration.Display_Method_Ancestry_Policy; |
| 124 | + |
| 125 | + Trace : constant GNATCOLL.Traces.Trace_Handle := |
| 126 | + Self.Parent.Context.Get_Trace_Handle; |
| 127 | + |
| 128 | + Name_Node : Libadalang.Analysis.Name; |
| 129 | + |
| 130 | + Definition : Libadalang.Analysis.Defining_Name; |
| 131 | + -- A defining name that corresponds to Name_Node |
| 132 | + First_Part : Libadalang.Analysis.Defining_Name; |
| 133 | + -- "Canonical part" of Definition |
| 134 | + Prev_Part : Libadalang.Analysis.Defining_Name; |
| 135 | + -- A previous name for Definition |
| 136 | + Decl_For_Find_Overrides : Libadalang.Analysis.Basic_Decl := |
| 137 | + Libadalang.Analysis.No_Basic_Decl; |
| 138 | + |
| 139 | + On_Defining_Name : Boolean := False; |
| 140 | + -- Set to True if we are on a denfining name node |
| 141 | + |
| 142 | + Ignore : Boolean; |
| 143 | + begin |
| 144 | + if Self.Contexts.Is_Empty then |
| 145 | + -- No more contexts to process, sort and return collected results |
| 146 | + LSP.Ada_Handlers.Locations.Sort (Self.Response); |
| 147 | + |
| 148 | + Client.On_Declaration_Response |
| 149 | + (Message.Id, |
| 150 | + (Kind => LSP.Structures.Variant_1, |
| 151 | + Variant_1 => Self.Response)); |
| 152 | + |
| 153 | + Status := LSP.Server_Jobs.Done; |
| 154 | + |
| 155 | + return; |
| 156 | + else |
| 157 | + Status := LSP.Server_Jobs.Continue; |
| 158 | + end if; |
| 159 | + |
| 160 | + Context := Self.Contexts.First_Element; |
| 161 | + Self.Contexts.Delete_First; |
| 162 | + |
| 163 | + Name_Node := Laltools.Common.Get_Node_As_Name |
| 164 | + (Self.Parent.Context.Get_Node_At (Context.all, Value)); |
| 165 | + |
| 166 | + if Name_Node.Is_Null then |
| 167 | + return; |
| 168 | + end if; |
| 169 | + |
| 170 | + -- Check if we are on some defining name |
| 171 | + Definition := Laltools.Common.Get_Name_As_Defining (Name_Node); |
| 172 | + |
| 173 | + if Definition.Is_Null then |
| 174 | + -- If we aren't on a defining_name already then try to resolve |
| 175 | + Definition := Laltools.Common.Resolve_Name (Name_Node, Trace, Ignore); |
| 176 | + else |
| 177 | + On_Defining_Name := True; |
| 178 | + end if; |
| 179 | + |
| 180 | + if Definition.Is_Null then |
| 181 | + return; -- Name resolution fails, nothing to do. |
| 182 | + end if; |
| 183 | + |
| 184 | + -- Display the method ancestry in three cases: |
| 185 | + -- |
| 186 | + -- . When the preference is set to Always |
| 187 | + -- |
| 188 | + -- . When we are on a usage node (e.g: subprogram call) and if the |
| 189 | + -- preference is set to Usage_And_Abstract_Only |
| 190 | + -- |
| 191 | + -- . When we are on a defining name node and if the preference is |
| 192 | + -- set to Definition_Only |
| 193 | + |
| 194 | + if Display_Method_Policy = Always |
| 195 | + or else (Display_Method_Policy = Usage_And_Abstract_Only |
| 196 | + and then not On_Defining_Name) |
| 197 | + or else (Display_Method_Policy = Definition_Only |
| 198 | + and then On_Defining_Name) |
| 199 | + then |
| 200 | + First_Part := Laltools.Common.Find_Canonical_Part (Definition, Trace); |
| 201 | + |
| 202 | + Decl_For_Find_Overrides := |
| 203 | + (if First_Part.Is_Null then Definition.P_Basic_Decl |
| 204 | + else First_Part.P_Basic_Decl); |
| 205 | + end if; |
| 206 | + |
| 207 | + begin |
| 208 | + Prev_Part := Definition.P_Previous_Part; |
| 209 | + exception |
| 210 | + when E : Libadalang.Common.Property_Error => |
| 211 | + Self.Parent.Context.Trace_Exception (E); |
| 212 | + Prev_Part := Libadalang.Analysis.No_Defining_Name; |
| 213 | + end; |
| 214 | + |
| 215 | + if not Prev_Part.Is_Null then |
| 216 | + -- We have found previous part, return it. |
| 217 | + Self.Parent.Context.Append_Location |
| 218 | + (Self.Response, |
| 219 | + Self.Filter, |
| 220 | + Prev_Part); |
| 221 | + elsif not Definition.Is_Null then |
| 222 | + -- No previous part, return definition itself. |
| 223 | + Self.Parent.Context.Append_Location |
| 224 | + (Self.Response, |
| 225 | + Self.Filter, |
| 226 | + Definition); |
| 227 | + end if; |
| 228 | + |
| 229 | + if not Decl_For_Find_Overrides.Is_Null then |
| 230 | + declare |
| 231 | + Overridings : constant Libadalang.Analysis.Basic_Decl_Array := |
| 232 | + Context.Find_All_Overrides |
| 233 | + (Decl_For_Find_Overrides, |
| 234 | + Imprecise_Results => Ignore); |
| 235 | + |
| 236 | + Bases : constant Libadalang.Analysis.Basic_Decl_Array := |
| 237 | + Context.Find_All_Base_Declarations |
| 238 | + (Decl_For_Find_Overrides, |
| 239 | + Imprecise_Results => Ignore); |
| 240 | + begin |
| 241 | + for Subp of Bases loop |
| 242 | + Self.Parent.Context.Append_Location |
| 243 | + (Self.Response, |
| 244 | + Self.Filter, |
| 245 | + Subp.P_Defining_Name, |
| 246 | + Is_Parent); |
| 247 | + end loop; |
| 248 | + |
| 249 | + for Subp of Overridings loop |
| 250 | + Self.Parent.Context.Append_Location |
| 251 | + (Self.Response, |
| 252 | + Self.Filter, |
| 253 | + Subp.P_Defining_Name, |
| 254 | + Is_Child); |
| 255 | + end loop; |
| 256 | + end; |
| 257 | + end if; |
| 258 | + end Execute_Request; |
| 259 | + |
| 260 | +end LSP.Ada_Declaration; |
0 commit comments