diff --git a/src/protocol/LSP.Capabilities.pas b/src/protocol/LSP.Capabilities.pas index 0083502..7b259d8 100644 --- a/src/protocol/LSP.Capabilities.pas +++ b/src/protocol/LSP.Capabilities.pas @@ -88,9 +88,30 @@ TWorkspaceServerCapabilities = class(TLSPStreamable) property workspaceFolders: TWorkspaceFoldersServerCapabilities read fWorkspaceFolders write SetWorkspaceFolders; end; + { TDocumentSymbolClientCapabilities } + + TDocumentSymbolClientCapabilities = class(TLSPStreamable) + private + fHierarchicalDocumentSymbolSupport: boolean; + Public + Procedure Assign(Source : TPersistent); override; + published + // The client supports hierarchical document symbols. + property hierarchicalDocumentSymbolSupport: boolean read fHierarchicalDocumentSymbolSupport write fHierarchicalDocumentSymbolSupport; + end; + { TTextDocumentClientCapabilities } TTextDocumentClientCapabilities = class(TLSPStreamable) + private + fDocumentSymbol: TDocumentSymbolClientCapabilities; + procedure SetDocumentSymbol(AValue: TDocumentSymbolClientCapabilities); + Public + constructor Create; override; + destructor Destroy; override; + Procedure Assign(Source : TPersistent); override; + published + property documentSymbol: TDocumentSymbolClientCapabilities read fDocumentSymbol write SetDocumentSymbol; end; { TClientCapabilities } @@ -159,6 +180,53 @@ TServerCapabilities = class(TLSPStreamable) implementation +{ TDocumentSymbolClientCapabilities } + +procedure TDocumentSymbolClientCapabilities.Assign(Source : TPersistent); +var + Src : TDocumentSymbolClientCapabilities absolute Source; +begin + if Source is TDocumentSymbolClientCapabilities then + begin + HierarchicalDocumentSymbolSupport := Src.HierarchicalDocumentSymbolSupport; + end + else + inherited Assign(Source); +end; + +{ TTextDocumentClientCapabilities } + +procedure TTextDocumentClientCapabilities.SetDocumentSymbol( + AValue: TDocumentSymbolClientCapabilities); +begin + if fDocumentSymbol=AValue then Exit; + fDocumentSymbol.Assign(AValue); +end; + +constructor TTextDocumentClientCapabilities.Create; +begin + Inherited; + fDocumentSymbol := TDocumentSymbolClientCapabilities.Create; +end; + +destructor TTextDocumentClientCapabilities.Destroy; +begin + FreeAndNil(fDocumentSymbol); + inherited Destroy; +end; + +procedure TTextDocumentClientCapabilities.Assign(Source : TPersistent); +var + Src : TTextDocumentClientCapabilities absolute Source; +begin + if Source is TTextDocumentClientCapabilities then + begin + DocumentSymbol := Src.DocumentSymbol; + end + else + inherited Assign(Source); +end; + { TWorkspaceClientCapabilities } procedure TWorkspaceClientCapabilities.Assign(Source : TPersistent); diff --git a/src/protocol/LSP.DocumentSymbol.pas b/src/protocol/LSP.DocumentSymbol.pas index bd6fa25..645dcf5 100644 --- a/src/protocol/LSP.DocumentSymbol.pas +++ b/src/protocol/LSP.DocumentSymbol.pas @@ -118,7 +118,7 @@ TSymbolInformation = class(TCollectionItem) fKind: TSymbolKind; fDeprecated: TOptionalBoolean; fLocation: TLocation; - fContainerName: string; + fContainerName: TOptionalString; procedure SetLocation(AValue: TLocation); Public constructor Create(ACollection: TCollection); override; @@ -145,11 +145,29 @@ TSymbolInformation = class(TCollectionItem) // user interface purposes (e.g. to render a qualifier in the user interface // if necessary). It can't be used to re-infer a hierarchy for the document // symbols. - property containerName: string read fContainerName write fContainerName; + property containerName: TOptionalString read fContainerName write fContainerName; end; TSymbolInformationItems = specialize TGenericCollection; + { TDocumentSymbolEx } + + { Extended DocumentSymbol with additional fields for pasls-specific needs } + + TSymbolFlag = (sfForwardDeclaration, sfDeprecated); + TSymbolFlags = set of TSymbolFlag; + + TDocumentSymbolEx = class(TDocumentSymbol) + private + fRawJSON: String; + fFlags: TSymbolFlags; + public + property RawJSON: String read fRawJSON write fRawJSON; + property Flags: TSymbolFlags read fFlags write fFlags; + end; + + TDocumentSymbolExItems = specialize TGenericCollection; + { TDocumentSymbolParams } TDocumentSymbolParams = class(TLSPStreamable) @@ -312,6 +330,7 @@ destructor TSymbolInformation.Destroy; begin FreeAndNil(fLocation); FreeAndNil(fDeprecated); + FreeAndNil(fContainerName); inherited Destroy; end; @@ -333,7 +352,15 @@ procedure TSymbolInformation.Assign(Source: TPersistent); else FreeAndNil(fDeprecated); Location:=Src.Location; - ContainerName:=Src.ContainerName; + if Assigned(Src.containerName) then + begin + if not assigned(fContainerName) then + fContainerName:=TOptionalString.Create(Src.containerName.Value) + else + fContainerName.Value:=Src.containerName.Value; + end + else + FreeAndNil(fContainerName); end else inherited Assign(Source); diff --git a/src/serverprotocol/PasLS.ApplyEdit.pas b/src/serverprotocol/PasLS.ApplyEdit.pas index b88bb59..74c5b10 100644 --- a/src/serverprotocol/PasLS.ApplyEdit.pas +++ b/src/serverprotocol/PasLS.ApplyEdit.pas @@ -34,7 +34,7 @@ implementation Uses { LSP } - PasLS.Settings, + PasLS.ClientProfile, LSP.BaseTypes, LSP.WorkSpace, PasLS.WorkSpace; @@ -58,7 +58,7 @@ procedure DoApplyEdit(aTransport: TMessageTransport; DocumentURI, Text: String; // but ideally you're supposed to provided correct versions. // See `OptionalVersionedTextDocumentIdentifier` from // https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#versionedTextDocumentIdentifier - if ClientInfo.name = TClients.SublimeTextLSP then + if TClientProfile.Current.HasFeature(cfNullDocumentVersion) then TextDocumentEdit.textDocument.version := nil else TextDocumentEdit.textDocument.version := 0; diff --git a/src/serverprotocol/PasLS.ClientProfile.pas b/src/serverprotocol/PasLS.ClientProfile.pas new file mode 100644 index 0000000..ce841bc --- /dev/null +++ b/src/serverprotocol/PasLS.ClientProfile.pas @@ -0,0 +1,217 @@ +// Pascal Language Server +// Copyright 2020 Ryan Joseph + +// This file is part of Pascal Language Server. + +// Pascal Language Server is free software: you can redistribute it +// and/or modify it under the terms of the GNU General Public License +// as published by the Free Software Foundation, either version 3 of +// the License, or (at your option) any later version. + +// Pascal Language Server is distributed in the hope that it will be +// useful, but WITHOUT ANY WARRANTY; without even the implied warranty +// of MERCHANTABILITY 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 +// along with Pascal Language Server. If not, see +// . +unit PasLS.ClientProfile; + +{$mode objfpc}{$H+} + +interface + +uses + { RTL } + Classes, SysUtils, Contnrs; + +type + { Feature flags for client-specific behaviors } + TClientFeature = ( + cfFlatSymbolMode, // Force flat symbol mode (SymbolInformation[]) + cfExcludeSectionContainers, // Don't include interface/implementation section containers + cfExcludeInterfaceMethodDecls, // Don't include method/function/procedure declarations from interface section + cfExcludeImplClassDefs, // Don't include class definitions from implementation section + cfNullDocumentVersion, // Use nil instead of 0 for document version + cfFilterTextOnly // Only set filterText in completion, not label + ); + TClientFeatures = set of TClientFeature; + + { Client profile class } + TClientProfile = class + private + FName: string; + FFeatures: TClientFeatures; + class var FCurrent: TClientProfile; + class var FDefault: TClientProfile; + class var FRegistry: TFPHashObjectList; + public + constructor Create(const AName: string; AFeatures: TClientFeatures); + + { Feature query - primary API } + function HasFeature(F: TClientFeature): Boolean; inline; + + { Properties } + property Name: string read FName; + property Features: TClientFeatures read FFeatures write FFeatures; + + { Class methods for profile management } + class procedure RegisterProfile(Profile: TClientProfile); + class procedure SelectProfile(const ClientName: string); + class procedure ApplyOverrides(EnableFeatures, DisableFeatures: TStrings); + class function Current: TClientProfile; + class procedure Finalize; + end; + +{ Helper function for string-to-feature conversion } +function TryStrToFeature(const S: string; out F: TClientFeature): Boolean; +function FeatureToStr(F: TClientFeature): string; + +implementation + +const + { Feature name mapping for configuration } + FeatureNames: array[TClientFeature] of string = ( + 'flatSymbolMode', + 'excludeSectionContainers', + 'excludeInterfaceMethodDecls', + 'excludeImplClassDefs', + 'nullDocumentVersion', + 'filterTextOnly' + ); + +function TryStrToFeature(const S: string; out F: TClientFeature): Boolean; +var + I: TClientFeature; +begin + Result := False; + for I := Low(TClientFeature) to High(TClientFeature) do + if SameText(S, FeatureNames[I]) then + begin + F := I; + Exit(True); + end; +end; + +function FeatureToStr(F: TClientFeature): string; +begin + Result := FeatureNames[F]; +end; + +{ TClientProfile } + +constructor TClientProfile.Create(const AName: string; AFeatures: TClientFeatures); +begin + inherited Create; + FName := AName; + FFeatures := AFeatures; +end; + +function TClientProfile.HasFeature(F: TClientFeature): Boolean; +begin + Result := F in FFeatures; +end; + +class procedure TClientProfile.RegisterProfile(Profile: TClientProfile); +begin + if FRegistry = nil then + FRegistry := TFPHashObjectList.Create(True); // Owns objects + FRegistry.Add(Profile.Name, Profile); +end; + +class procedure TClientProfile.SelectProfile(const ClientName: string); +begin + // Free previous copied profile if exists (not in registry and not FDefault) + if (FCurrent <> nil) and (FCurrent <> FDefault) then + if (FRegistry = nil) or (FRegistry.Find(FCurrent.Name) <> FCurrent) then + FreeAndNil(FCurrent); + + FCurrent := nil; + if FRegistry <> nil then + FCurrent := TClientProfile(FRegistry.Find(ClientName)); + if FCurrent = nil then + FCurrent := FDefault; +end; + +class procedure TClientProfile.ApplyOverrides(EnableFeatures, DisableFeatures: TStrings); +var + I: Integer; + Feature: TClientFeature; + OriginalProfile: TClientProfile; + OldCurrent: TClientProfile; +begin + if FCurrent = nil then Exit; + + // Check if we need to create a mutable copy + OriginalProfile := nil; + if FRegistry <> nil then + OriginalProfile := TClientProfile(FRegistry.Find(FCurrent.Name)); + + // Need to create a copy if: + // - FCurrent is the registered profile (OriginalProfile = FCurrent), OR + // - FCurrent is FDefault (check by object identity, not name lookup) + if (FCurrent = FDefault) or (FCurrent = OriginalProfile) then + begin + OldCurrent := FCurrent; + // Create a copy so we don't modify the registered or default profile + FCurrent := TClientProfile.Create(OldCurrent.Name, OldCurrent.Features); + // Note: We don't free OldCurrent here as it's owned by registry or is FDefault + end; + + // Apply enable overrides + if EnableFeatures <> nil then + for I := 0 to EnableFeatures.Count - 1 do + if TryStrToFeature(EnableFeatures[I], Feature) then + Include(FCurrent.FFeatures, Feature); + + // Apply disable overrides (takes precedence) + if DisableFeatures <> nil then + for I := 0 to DisableFeatures.Count - 1 do + if TryStrToFeature(DisableFeatures[I], Feature) then + Exclude(FCurrent.FFeatures, Feature); +end; + +class function TClientProfile.Current: TClientProfile; +begin + if FCurrent = nil then + FCurrent := FDefault; + Result := FCurrent; +end; + +class procedure TClientProfile.Finalize; +begin + // Free FCurrent if it's a copy (not in registry and not FDefault) + if (FCurrent <> nil) and (FCurrent <> FDefault) then + begin + if (FRegistry = nil) or (FRegistry.Find(FCurrent.Name) <> FCurrent) then + FreeAndNil(FCurrent); + end; + FCurrent := nil; + FreeAndNil(FRegistry); + FreeAndNil(FDefault); +end; + +initialization + // Create default profile (LSP-compliant, no special behaviors) + TClientProfile.FDefault := TClientProfile.Create('Default', []); + + // Register Sublime Text LSP profile + TClientProfile.RegisterProfile( + TClientProfile.Create('Sublime Text LSP', [ + cfFlatSymbolMode, + cfExcludeSectionContainers, + cfExcludeInterfaceMethodDecls, + cfExcludeImplClassDefs, + cfNullDocumentVersion, + cfFilterTextOnly + ])); + + // Register VS Code profile (uses LSP defaults) + TClientProfile.RegisterProfile( + TClientProfile.Create('vscode', [])); + +finalization + TClientProfile.Finalize; + +end. diff --git a/src/serverprotocol/PasLS.Completion.pas b/src/serverprotocol/PasLS.Completion.pas index b8eec00..ed7f43d 100644 --- a/src/serverprotocol/PasLS.Completion.pas +++ b/src/serverprotocol/PasLS.Completion.pas @@ -55,32 +55,19 @@ implementation uses SysUtils, Contnrs, - PasLS.CodeUtils, PasLS.Diagnostics, PasLS.Settings, LSP.Messages; + PasLS.CodeUtils, PasLS.Diagnostics, PasLS.Settings, PasLS.ClientProfile; procedure TCompletionItemHelper.SetPrimaryText(text: string); - begin - if ClientInfo.name = TClients.SublimeTextLSP then - begin - filterText := text; - end - else - begin - filterText := text; - &label := text; - end; + filterText := text; + if not TClientProfile.Current.HasFeature(cfFilterTextOnly) then + &label := text; end; procedure TCompletionItemHelper.SetSecondaryText(text: string); begin - if ClientInfo.name = TClients.SublimeTextLSP then - begin - &label := text; - end - else - begin - // todo: append to details? - end; + if not TClientProfile.Current.HasFeature(cfFilterTextOnly) then + &label := text; end; diff --git a/src/serverprotocol/PasLS.General.pas b/src/serverprotocol/PasLS.General.pas index 45e98de..82d811a 100644 --- a/src/serverprotocol/PasLS.General.pas +++ b/src/serverprotocol/PasLS.General.pas @@ -100,7 +100,7 @@ TCancel = class(specialize TLSPNotification) implementation uses - SysUtils, RegExpr, IdentCompletionTool, DefineTemplates; + SysUtils, RegExpr, IdentCompletionTool, DefineTemplates, PasLS.ClientProfile; const @@ -270,6 +270,7 @@ procedure TInitialize.ShowConfigStatus(Params : TInitializeParams; CodeToolsOpti DoLog( kStatusPrefix+'FPCPath: ' + CodeToolsOptions.FPCPath); DoLog( kStatusPrefix+'FPCSrcDir: ' + CodeToolsOptions.FPCSrcDir); + DoLog( kStatusPrefix+'LazarusSrcDir: ' + CodeToolsOptions.LazarusSrcDir); DoLog( kStatusPrefix+'TargetOS: ' + CodeToolsOptions.TargetOS); DoLog( kStatusPrefix+'TargetProcessor: '+ CodeToolsOptions.TargetProcessor); @@ -384,6 +385,24 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu ServerSettings.Assign(Params.initializationOptions); PasLS.Settings.ClientInfo.Assign(Params.ClientInfo); + // Select client profile based on client name + TClientProfile.SelectProfile(Params.ClientInfo.name); + + // Apply user overrides from initializationOptions + if (ServerSettings.clientProfileEnableFeatures.Count > 0) or + (ServerSettings.clientProfileDisableFeatures.Count > 0) then + TClientProfile.ApplyOverrides( + ServerSettings.clientProfileEnableFeatures, + ServerSettings.clientProfileDisableFeatures); + + // Detect hierarchical document symbol support + if Assigned(Params.capabilities) and + Assigned(Params.capabilities.textDocument) and + Assigned(Params.capabilities.textDocument.documentSymbol) then + SetClientCapabilities(Params.capabilities.textDocument.documentSymbol.hierarchicalDocumentSymbolSupport) + else + SetClientCapabilities(false); + // replace macros in server settings Macros.Add('tmpdir', GetTempDir(true)); Macros.Add('root', URIToPath(Params.rootUri)); @@ -427,6 +446,7 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu if ServerSettings.documentSymbols or ServerSettings.workspaceSymbols then begin SymbolManager := TSymbolManager.Create; + SymbolManager.Transport := Transport; Result.capabilities.documentSymbolProvider:=True; Result.capabilities.workspaceSymbolProvider := ServerSettings.CanProvideWorkspaceSymbols; end; diff --git a/src/serverprotocol/PasLS.Settings.pas b/src/serverprotocol/PasLS.Settings.pas index 67e9385..4457976 100644 --- a/src/serverprotocol/PasLS.Settings.pas +++ b/src/serverprotocol/PasLS.Settings.pas @@ -53,8 +53,12 @@ TServerSettings = class(TInitializationOptions) fMaximumCompletions: Integer; fOverloadPolicy: TOverloadPolicy; fConfig: String; + fClientProfileEnableFeatures: TStrings; + fClientProfileDisableFeatures: TStrings; procedure SetFPCOptions(AValue: TStrings); procedure SetExcludeWorkspaceFolders(AValue: TStrings); + procedure SetClientProfileEnableFeatures(AValue: TStrings); + procedure SetClientProfileDisableFeatures(AValue: TStrings); published // Path to the main program file for resolving references // if not available the path of the current document will be used @@ -99,6 +103,11 @@ TServerSettings = class(TInitializationOptions) property config: String read fConfig write fConfig; // Check inactive regions property checkInactiveRegions : Boolean read fBooleans[11] write fBooleans[11]; + // Client profile feature overrides + property clientProfileEnableFeatures: TStrings + read fClientProfileEnableFeatures write SetClientProfileEnableFeatures; + property clientProfileDisableFeatures: TStrings + read fClientProfileDisableFeatures write SetClientProfileDisableFeatures; public constructor Create; override; Destructor Destroy; override; @@ -231,6 +240,8 @@ procedure TServerSettings.Assign(aSource : TPersistent); MaximumCompletions:=Src.MaximumCompletions; OverloadPolicy:=Src.OverloadPolicy; Config:=Src.Config; + ClientProfileEnableFeatures := Src.ClientProfileEnableFeatures; + ClientProfileDisableFeatures := Src.ClientProfileDisableFeatures; end else inherited Assign(aSource); @@ -248,6 +259,18 @@ procedure TServerSettings.SetExcludeWorkspaceFolders(AValue: TStrings); fExcludeWorkspaceFolders.Assign(AValue); end; +procedure TServerSettings.SetClientProfileEnableFeatures(AValue: TStrings); +begin + if fClientProfileEnableFeatures = AValue then Exit; + fClientProfileEnableFeatures.Assign(AValue); +end; + +procedure TServerSettings.SetClientProfileDisableFeatures(AValue: TStrings); +begin + if fClientProfileDisableFeatures = AValue then Exit; + fClientProfileDisableFeatures.Assign(AValue); +end; + function TServerSettings.CanProvideWorkspaceSymbols: boolean; begin result := workspaceSymbols and @@ -278,6 +301,8 @@ class function TServerSettings.GetPropertyDescription(const PropName: String): S 'ignoreTextCompletions': Result := 'Ignores completion items like "begin" and "var"'; 'config': Result := 'Config file or directory to read settings from'; 'checkInactiveRegions': Result := 'Check inactive regions'; + 'clientProfileEnableFeatures': Result := 'List of features to force-enable regardless of client profile'; + 'clientProfileDisableFeatures': Result := 'List of features to force-disable regardless of client profile'; else Result := ''; end; @@ -289,6 +314,8 @@ constructor TServerSettings.Create; fFPCOptions := TStringList.Create; fExcludeWorkspaceFolders := TStringList.Create; + fClientProfileEnableFeatures := TStringList.Create; + fClientProfileDisableFeatures := TStringList.Create; // default settings symbolDatabase := ''; @@ -314,6 +341,8 @@ destructor TServerSettings.Destroy; begin FreeAndNil(fFPCOptions); FreeAndNil(fExcludeWorkspaceFolders); + FreeAndNil(fClientProfileEnableFeatures); + FreeAndNil(fClientProfileDisableFeatures); inherited Destroy; end; diff --git a/src/serverprotocol/PasLS.Symbols.pas b/src/serverprotocol/PasLS.Symbols.pas index ace357c..77d3313 100644 --- a/src/serverprotocol/PasLS.Symbols.pas +++ b/src/serverprotocol/PasLS.Symbols.pas @@ -78,6 +78,69 @@ TSymbolTableEntry = class property RawJSON: String read GetRawJSON; end; + { TSymbolBuilder } + + { Dual-mode symbol builder supporting both SymbolInformation (legacy) + and DocumentSymbol (LSP 3.10+) output formats } + + TSymbolMode = ( + smFlat, // Output SymbolInformation[] with Class.Method naming (Lazarus style) + smHierarchical // Output DocumentSymbol[] with nested children (LSP 3.10+) + ); + +type + + TSymbolBuilder = class + private + FMode: TSymbolMode; + FEntry: TSymbolTableEntry; + FTool: TCodeTool; + + // For hierarchical mode: map className -> TDocumentSymbolEx + FClassMap: TFPHashObjectList; + FRootSymbols: TDocumentSymbolExItems; + + // For tracking current hierarchy + FCurrentClass: TDocumentSymbolEx; + // Last added function/method (for nested function support) + FLastAddedFunction: TDocumentSymbolEx; + + // For Interface/Implementation namespaces (hierarchical mode) + FInterfaceSymbol: TDocumentSymbolEx; + FImplementationSymbol: TDocumentSymbolEx; + FCurrentSectionSymbol: TDocumentSymbolEx; + + function FindOrCreateClass(const AClassName: String; Node: TCodeTreeNode; IsImplementationContainer: Boolean = False): TDocumentSymbolEx; + procedure SetNodeRange(Symbol: TDocumentSymbolEx; Node: TCodeTreeNode); + function GetCurrentContainer: TDocumentSymbolExItems; + function AddFlatSymbol(Node: TCodeTreeNode; const Name: String; Kind: TSymbolKind; const ContainerName: String = ''): TSymbol; + public + constructor Create(AEntry: TSymbolTableEntry; ATool: TCodeTool; AMode: TSymbolMode); + destructor Destroy; override; + + // Section management (hierarchical mode) + procedure BeginInterfaceSection(Node: TCodeTreeNode); + procedure BeginImplementationSection(Node: TCodeTreeNode); + + // Add symbols based on mode + function AddClass(Node: TCodeTreeNode; const Name: String): TSymbol; + function AddMethod(Node: TCodeTreeNode; const AClassName, AMethodName: String): TSymbol; + function AddGlobalFunction(Node: TCodeTreeNode; const Name: String): TSymbol; + function AddStruct(Node: TCodeTreeNode; const Name: String): TSymbol; + function AddProperty(Node: TCodeTreeNode; const AClassName, APropertyName: String): TSymbol; + function AddField(Node: TCodeTreeNode; const AClassName, AFieldName: String): TSymbol; + // Add nested function as child of parent + function AddNestedFunction(Parent: TDocumentSymbolEx; Node: TCodeTreeNode; const Name, ParentPath: String): TDocumentSymbolEx; + + // Serialization + procedure SerializeSymbols; + + property Mode: TSymbolMode read FMode; + property CurrentClass: TDocumentSymbolEx read FCurrentClass write FCurrentClass; + property RootSymbols: TDocumentSymbolExItems read FRootSymbols; + property LastAddedFunction: TDocumentSymbolEx read FLastAddedFunction; + end; + { TSymbolExtractor } TSymbolExtractor = class @@ -85,16 +148,21 @@ TSymbolExtractor = class Code: TCodeBuffer; Tool: TCodeTool; Entry: TSymbolTableEntry; + Builder: TSymbolBuilder; OverloadMap: TFPHashList; RelatedFiles: TFPHashList; IndentLevel: integer; CodeSection: TCodeTreeNodeDesc; + function ShouldExcludeInterfaceDecl: Boolean; + function ShouldExcludeImplClass: Boolean; private procedure PrintNodeDebug(Node: TCodeTreeNode; Deep: boolean = false); + procedure AdjustEndPosition(Node: TCodeTreeNode; var EndPos: TCodeXYPosition); function AddSymbol(Node: TCodeTreeNode; Kind: TSymbolKind): TSymbol; overload; function AddSymbol(Node: TCodeTreeNode; Kind: TSymbolKind; Name: String; Container: String = ''): TSymbol; overload; procedure ExtractCodeSection(Node: TCodeTreeNode); function ExtractProcedure(ParentNode, Node: TCodeTreeNode):TSymbol; + procedure ProcessNestedFunctions(Node: TCodeTreeNode; ParentSymbol: TDocumentSymbolEx; const ParentPath: String); procedure ExtractTypeDefinition(TypeDefNode, Node: TCodeTreeNode); procedure ExtractObjCClassMethods(ClassNode, Node: TCodeTreeNode); public @@ -185,15 +253,81 @@ TSymbolManager = class var SymbolManager: TSymbolManager = nil; +// Client capabilities and configuration storage +var + ClientSupportsDocumentSymbol: Boolean = False; + +function GetSymbolMode: TSymbolMode; +procedure SetClientCapabilities(SupportsDocumentSymbol: Boolean); + +{ Adjusts EndPos for LSP Range specification (end position must be exclusive). + For section nodes, moves back one line to not include next section. + For other nodes, moves forward one character to make end exclusive. } +procedure AdjustEndPositionForLSP(Node: TCodeTreeNode; var EndPos: TCodeXYPosition); + implementation uses { RTL } - SysUtils, FileUtil, DateUtils, fpjsonrtti, + SysUtils, FileUtil, DateUtils, fpjsonrtti, { Code Tools } CodeAtom, FindDeclarationTool, KeywordFuncLists,PascalParserTool, { Protocol } - PasLS.Settings; + PasLS.Settings, PasLS.ClientProfile; + +function GetSymbolMode: TSymbolMode; +begin + // Priority 1: Client profile forces flat mode + if TClientProfile.Current.HasFeature(cfFlatSymbolMode) then + Exit(smFlat); + + // Priority 2: Auto mode - use hierarchical if client supports it and server enables it + if ClientSupportsDocumentSymbol and ServerSettings.documentSymbols then + Result := smHierarchical + else + Result := smFlat; +end; + +procedure SetClientCapabilities(SupportsDocumentSymbol: Boolean); +begin + ClientSupportsDocumentSymbol := SupportsDocumentSymbol; +end; + +procedure AdjustEndPositionForLSP(Node: TCodeTreeNode; var EndPos: TCodeXYPosition); +var + LineText: String; +begin + if Node.Desc in AllCodeSections then + begin + // For section nodes (interface/implementation), CodeTools EndPos points to + // the start of the NEXT section (or end of file). We need to move back + // one line so we don't include the next section's first line. + if EndPos.Y > 1 then + begin + Dec(EndPos.Y); + // Set X to end of the previous line (past last char for exclusive end) + if (EndPos.Code <> nil) and (EndPos.Y <= EndPos.Code.LineCount) then + EndPos.X := Length(EndPos.Code.GetLine(EndPos.Y - 1, false)) + 1 + else + EndPos.X := 1; + end; + end + else + begin + // For non-section nodes, move EndPos one position forward to make it exclusive + if (EndPos.Code <> nil) and (EndPos.Y > 0) and (EndPos.Y <= EndPos.Code.LineCount) then + begin + LineText := EndPos.Code.GetLine(EndPos.Y - 1, false); + if EndPos.X <= Length(LineText) then + Inc(EndPos.X) + else + // EndPos.X already points past the last character on this line. + // Keep it on the same line - don't move to next line. + // This prevents single-line symbols from having range extend to next line. + EndPos.X := Length(LineText) + 1; + end; + end; +end; function GetFileKey(Path: String): ShortString; begin @@ -219,13 +353,13 @@ function TSymbol.Path: String; function TSymbol.IsGlobal: boolean; begin - result := containerName <> ''; + result := Assigned(containerName) and (containerName.Value <> ''); end; function TSymbol.GetFullName: String; begin - if containerName <> '' then - Result := containerName+'.'+Name + if Assigned(containerName) and (containerName.Value <> '') then + Result := containerName.Value+'.'+Name else Result := Name; end; @@ -236,6 +370,437 @@ constructor TSymbol.Create; Create(nil); end; +{ TSymbolBuilder } + +constructor TSymbolBuilder.Create(AEntry: TSymbolTableEntry; ATool: TCodeTool; AMode: TSymbolMode); +begin + FEntry := AEntry; + FTool := ATool; + FMode := AMode; + FCurrentClass := nil; + + if FMode = smHierarchical then + begin + FClassMap := TFPHashObjectList.Create(False); // Don't own objects - they're owned by FRootSymbols + FRootSymbols := TDocumentSymbolExItems.Create; + end; +end; + +destructor TSymbolBuilder.Destroy; +begin + if FMode = smHierarchical then + begin + FreeAndNil(FClassMap); + FreeAndNil(FRootSymbols); + end; + inherited; +end; + +procedure TSymbolBuilder.SetNodeRange(Symbol: TDocumentSymbolEx; Node: TCodeTreeNode); +var + StartPos, EndPos, NamePos: TCodeXYPosition; +begin + if (FTool = nil) or (Symbol = nil) or (Node = nil) then + Exit; + + FTool.CleanPosToCaret(Node.StartPos, StartPos); + FTool.CleanPosToCaret(Node.EndPos, EndPos); + + // Use shared adjustment logic for LSP Range specification + AdjustEndPositionForLSP(Node, EndPos); + + Symbol.range.SetRange(StartPos.Y - 1, StartPos.X - 1, EndPos.Y - 1, EndPos.X - 1); + + // For procedure/function nodes, find the actual name position + // Node.StartPos points to keyword ("procedure"/"function"), but we need + // the name position for selectionRange to highlight correctly in editors + if Node.Desc = ctnProcedure then + begin + FTool.MoveCursorToProcName(Node, True); // True = skip className prefix + FTool.CleanPosToCaret(FTool.CurPos.StartPos, NamePos); + Symbol.selectionRange.SetRange(NamePos.Y - 1, NamePos.X - 1, NamePos.Y - 1, NamePos.X - 1 + Length(Symbol.name)); + end + else + Symbol.selectionRange.SetRange(StartPos.Y - 1, StartPos.X - 1, StartPos.Y - 1, StartPos.X - 1 + Length(Symbol.name)); +end; + +function TSymbolBuilder.GetCurrentContainer: TDocumentSymbolExItems; +begin + // In hierarchical mode, return the current section's children if available + if (FMode = smHierarchical) and (FCurrentSectionSymbol <> nil) then + Result := TDocumentSymbolExItems(FCurrentSectionSymbol.children) + else + Result := FRootSymbols; +end; + +function TSymbolBuilder.AddFlatSymbol(Node: TCodeTreeNode; const Name: String; Kind: TSymbolKind; const ContainerName: String = ''): TSymbol; +var + CodePos, EndPos: TCodeXYPosition; +begin + Result := nil; + if (FTool <> nil) and (Node <> nil) then + begin + FTool.CleanPosToCaret(Node.StartPos, CodePos); + FTool.CleanPosToCaret(Node.EndPos, EndPos); + // Adjust EndPos for LSP Range specification (end position must be exclusive) + AdjustEndPositionForLSP(Node, EndPos); + Result := FEntry.AddSymbol(Name, Kind, + CodePos.Code.FileName, + CodePos.Y, CodePos.X, + EndPos.Y, EndPos.X); + // Set containerName for LSP semantics in workspace/symbol + if (Result <> nil) and (ContainerName <> '') then + Result.containerName := TOptionalString.Create(ContainerName); + end; +end; + +procedure TSymbolBuilder.BeginInterfaceSection(Node: TCodeTreeNode); +begin + if FMode <> smHierarchical then + Exit; + + // Create interface namespace symbol + FInterfaceSymbol := TDocumentSymbolEx.Create(FRootSymbols); + FInterfaceSymbol.name := kSymbolName_Interface; + FInterfaceSymbol.kind := TSymbolKind._Namespace; + SetNodeRange(FInterfaceSymbol, Node); + FCurrentSectionSymbol := FInterfaceSymbol; +end; + +procedure TSymbolBuilder.BeginImplementationSection(Node: TCodeTreeNode); +begin + if FMode <> smHierarchical then + Exit; + + // Create implementation namespace symbol + FImplementationSymbol := TDocumentSymbolEx.Create(FRootSymbols); + FImplementationSymbol.name := kSymbolName_Implementation; + FImplementationSymbol.kind := TSymbolKind._Namespace; + SetNodeRange(FImplementationSymbol, Node); + FCurrentSectionSymbol := FImplementationSymbol; +end; + +function TSymbolBuilder.FindOrCreateClass(const AClassName: String; Node: TCodeTreeNode; IsImplementationContainer: Boolean = False): TDocumentSymbolEx; +var + Container: TDocumentSymbolExItems; + Key: String; +begin + Result := nil; + + if FMode <> smHierarchical then + Exit; + + // F1 Scheme: Classes exist in both Interface and Implementation namespaces + // Use section-specific key to distinguish between interface declaration and implementation methods + // Note: Must check for nil first, otherwise nil = nil is True for program files + if (FInterfaceSymbol <> nil) and (FCurrentSectionSymbol = FInterfaceSymbol) then + Key := 'interface.' + AClassName + else if (FImplementationSymbol <> nil) and (FCurrentSectionSymbol = FImplementationSymbol) then + Key := 'implementation.' + AClassName + else + begin + // Program files: distinguish between declaration and implementation container + if IsImplementationContainer then + Key := AClassName + '.impl' + else + Key := AClassName; + end; + + // Check if class already exists in current section + Result := TDocumentSymbolEx(FClassMap.Find(Key)); + + if Result = nil then + begin + // Create class in current section's namespace + Container := GetCurrentContainer; + + Result := TDocumentSymbolEx.Create(Container); + Result.name := AClassName; + Result.kind := TSymbolKind._Class; + + // Set ranges using the node + if Node <> nil then + SetNodeRange(Result, Node); + + // Add reference to class map for lookup with section-specific key + FClassMap.Add(Key, Result); + end; +end; + +function TSymbolBuilder.AddClass(Node: TCodeTreeNode; const Name: String): TSymbol; +begin + case FMode of + smFlat: + begin + // Flat mode: add class to Entry.Symbols + Result := AddFlatSymbol(Node, Name, TSymbolKind._Class); + end; + + smHierarchical: + begin + // Hierarchical mode: Create class in current section's namespace + // - Interface section: class declaration + // - Implementation section: class with method implementations (rare) + FCurrentClass := FindOrCreateClass(Name, Node); + // Also add to flat symbol list for database/workspace symbol + Result := AddFlatSymbol(Node, Name, TSymbolKind._Class); + end; + end; +end; + +function TSymbolBuilder.AddMethod(Node: TCodeTreeNode; const AClassName, AMethodName: String): TSymbol; +var + ClassSymbol: TDocumentSymbolEx; + MethodSymbol: TDocumentSymbolEx; +begin + case FMode of + smFlat: + begin + // Flat mode: Class.Method naming, no containerName (Lazarus style) + Result := AddFlatSymbol(Node, AClassName + '.' + AMethodName, TSymbolKind._Method); + end; + + smHierarchical: + begin + // Hierarchical mode: Add method as child of class + ClassSymbol := FindOrCreateClass(AClassName, nil, True); + if ClassSymbol <> nil then + begin + MethodSymbol := TDocumentSymbolEx.Create(ClassSymbol.children); + MethodSymbol.name := AMethodName; + MethodSymbol.kind := TSymbolKind._Method; + SetNodeRange(MethodSymbol, Node); + FLastAddedFunction := MethodSymbol; + + // Initialize or extend class range to include method + if (ClassSymbol.range.start.line = 0) and (ClassSymbol.range.&end.line = 0) then + begin + // First method - initialize class range + ClassSymbol.range.start.line := MethodSymbol.range.start.line; + ClassSymbol.range.start.character := MethodSymbol.range.start.character; + ClassSymbol.range.&end.line := MethodSymbol.range.&end.line; + ClassSymbol.range.&end.character := MethodSymbol.range.&end.character; + ClassSymbol.selectionRange := ClassSymbol.range; + end + else + begin + // Extend class range to include this method + if MethodSymbol.range.start.line < ClassSymbol.range.start.line then + begin + ClassSymbol.range.start.line := MethodSymbol.range.start.line; + ClassSymbol.range.start.character := MethodSymbol.range.start.character; + end; + if MethodSymbol.range.&end.line > ClassSymbol.range.&end.line then + begin + ClassSymbol.range.&end.line := MethodSymbol.range.&end.line; + ClassSymbol.range.&end.character := MethodSymbol.range.&end.character; + end; + end; + end; + + // Add to flat symbol list for database/workspace symbol with LSP semantics + // name=MethodName, containerName=ClassName + Result := AddFlatSymbol(Node, AMethodName, TSymbolKind._Method, AClassName); + end; + end; +end; + +function TSymbolBuilder.AddGlobalFunction(Node: TCodeTreeNode; const Name: String): TSymbol; +var + GlobalSymbol: TDocumentSymbolEx; +begin + case FMode of + smFlat: + begin + // Flat mode: add function to Entry.Symbols + Result := AddFlatSymbol(Node, Name, TSymbolKind._Function); + end; + + smHierarchical: + begin + // Hierarchical mode: Add to current container (Interface or Implementation namespace) + GlobalSymbol := TDocumentSymbolEx.Create(GetCurrentContainer); + GlobalSymbol.name := Name; + GlobalSymbol.kind := TSymbolKind._Function; + SetNodeRange(GlobalSymbol, Node); + FLastAddedFunction := GlobalSymbol; + // Also add to flat symbol list for database/workspace symbol + Result := AddFlatSymbol(Node, Name, TSymbolKind._Function); + end; + end; +end; + +function TSymbolBuilder.AddStruct(Node: TCodeTreeNode; const Name: String): TSymbol; +var + StructSymbol: TDocumentSymbolEx; +begin + case FMode of + smFlat: + begin + // Flat mode: add struct to Entry.Symbols + Result := AddFlatSymbol(Node, Name, TSymbolKind._Struct); + end; + + smHierarchical: + begin + // Hierarchical mode: Add struct to current container + StructSymbol := TDocumentSymbolEx.Create(GetCurrentContainer); + StructSymbol.name := Name; + StructSymbol.kind := TSymbolKind._Struct; + SetNodeRange(StructSymbol, Node); + // Also add to flat symbol list for database/workspace symbol + Result := AddFlatSymbol(Node, Name, TSymbolKind._Struct); + end; + end; +end; + +function TSymbolBuilder.AddProperty(Node: TCodeTreeNode; const AClassName, APropertyName: String): TSymbol; +var + ClassSymbol: TDocumentSymbolEx; + PropertySymbol: TDocumentSymbolEx; +begin + case FMode of + smFlat: + begin + // Flat mode: Class.Property naming, no containerName (Lazarus style) + Result := AddFlatSymbol(Node, AClassName + '.' + APropertyName, TSymbolKind._Property); + end; + + smHierarchical: + begin + // Hierarchical mode: add property to class's children + ClassSymbol := FindOrCreateClass(AClassName, Node); + if ClassSymbol <> nil then + begin + PropertySymbol := TDocumentSymbolEx.Create(ClassSymbol.children); + PropertySymbol.name := APropertyName; + PropertySymbol.kind := TSymbolKind._Property; + SetNodeRange(PropertySymbol, Node); + end; + // Add to flat symbol list with LSP semantics + Result := AddFlatSymbol(Node, APropertyName, TSymbolKind._Property, AClassName); + end; + end; +end; + +function TSymbolBuilder.AddField(Node: TCodeTreeNode; const AClassName, AFieldName: String): TSymbol; +var + ClassSymbol: TDocumentSymbolEx; + FieldSymbol: TDocumentSymbolEx; +begin + case FMode of + smFlat: + begin + // Flat mode: Class.Field naming, no containerName (Lazarus style) + Result := AddFlatSymbol(Node, AClassName + '.' + AFieldName, TSymbolKind._Field); + end; + + smHierarchical: + begin + // Hierarchical mode: add field to class's children + ClassSymbol := FindOrCreateClass(AClassName, Node); + if ClassSymbol <> nil then + begin + FieldSymbol := TDocumentSymbolEx.Create(ClassSymbol.children); + FieldSymbol.name := AFieldName; + FieldSymbol.kind := TSymbolKind._Field; + SetNodeRange(FieldSymbol, Node); + end; + // Add to flat symbol list with LSP semantics + Result := AddFlatSymbol(Node, AFieldName, TSymbolKind._Field, AClassName); + end; + end; +end; + +function TSymbolBuilder.AddNestedFunction(Parent: TDocumentSymbolEx; Node: TCodeTreeNode; const Name, ParentPath: String): TDocumentSymbolEx; +var + FullPath: String; +begin + Result := nil; + FullPath := ParentPath + '.' + Name; + + case FMode of + smFlat: + begin + // Flat mode: full path name, no containerName (Lazarus style) + AddFlatSymbol(Node, FullPath, TSymbolKind._Function); + end; + + smHierarchical: + begin + if Parent = nil then + Exit; + + // Create nested function as child of parent + Result := TDocumentSymbolEx.Create(Parent.children); + Result.name := Name; + Result.kind := TSymbolKind._Function; + SetNodeRange(Result, Node); + + // Add to flat symbol list with LSP semantics + // name=NestedName, containerName=ParentPath + AddFlatSymbol(Node, Name, TSymbolKind._Function, ParentPath); + end; + end; +end; + +procedure TSymbolBuilder.SerializeSymbols; +const + BATCH_COUNT = 1000; +var + SerializedItems: TJSONArray; + i, Start, Next, Total: Integer; + Symbol: TSymbol; +begin + case FMode of + smFlat: + begin + // Use existing serialization for flat SymbolInformation[] + FEntry.SerializeSymbols; + end; + + smHierarchical: + begin + // Serialize DocumentSymbol hierarchy for textDocument/documentSymbol + SerializedItems := specialize TLSPStreaming.ToJSON(FRootSymbols) as TJSONArray; + try + FEntry.fRawJSON := SerializedItems.AsJSON; + finally + SerializedItems.Free; + end; + + // Serialize flat SymbolInformation[] for database insertion and workspace/symbol + SerializedItems := specialize TLSPStreaming.ToJSON(FEntry.Symbols) as TJSONArray; + try + // Set RawJSON for each symbol (needed for database insertion) + for i := 0 to SerializedItems.Count - 1 do + begin + Symbol := FEntry.Symbols.Items[i]; + Symbol.RawJSON := SerializedItems[i].AsJson; + end; + + // Insert symbols into database if available + if SymbolManager.Database <> nil then + begin + Next := 0; + Start := 0; + Total := SerializedItems.Count; + while Start < Total do + begin + Next := Start + BATCH_COUNT; + if Next >= Total then + Next := Total - 1; + SymbolManager.Database.InsertSymbols(FEntry.Symbols, Start, Next); + Start := Next + 1; + end; + end; + finally + SerializedItems.Free; + end; + end; + end; +end; + { TSymbolTableEntry } function TSymbolTableEntry.GetRawJSON: String; @@ -391,34 +956,39 @@ function TSymbolExtractor.AddSymbol(Node: TCodeTreeNode; Kind: TSymbolKind): TSy result := AddSymbol(Node, Kind, GetIdentifierAtPos(Tool, Node.StartPos, true, true)); end; +procedure TSymbolExtractor.AdjustEndPosition(Node: TCodeTreeNode; var EndPos: TCodeXYPosition); +begin + AdjustEndPositionForLSP(Node, EndPos); +end; + +function TSymbolExtractor.ShouldExcludeInterfaceDecl: Boolean; +begin + Result := (Builder.Mode = smFlat) and + (CodeSection = ctnInterface) and + TClientProfile.Current.HasFeature(cfExcludeInterfaceMethodDecls); +end; + +function TSymbolExtractor.ShouldExcludeImplClass: Boolean; +begin + Result := (Builder.Mode = smFlat) and + (CodeSection = ctnImplementation) and + TClientProfile.Current.HasFeature(cfExcludeImplClassDefs); +end; + function TSymbolExtractor.AddSymbol(Node: TCodeTreeNode; Kind: TSymbolKind; Name: String; Container: String): TSymbol; var - CodePos,EndPos: TCodeXYPosition; + CodePos, EndPos: TCodeXYPosition; FileName: String; - LineText: String; begin {$ifdef SYMBOL_DEBUG} writeln(IndentLevelString(IndentLevel + 1), '* ', Name); {$endif} Tool.CleanPosToCaret(Node.StartPos, CodePos); - Tool.CleanPosToCaret(Node.EndPos,EndPos); + Tool.CleanPosToCaret(Node.EndPos, EndPos); - // Fix for LSP Range specification: end position must be exclusive - // Move EndPos one position forward to make it exclusive - if (EndPos.Code <> nil) and (EndPos.Y > 0) and (EndPos.Y <= EndPos.Code.LineCount) then - begin - LineText := EndPos.Code.GetLine(EndPos.Y - 1, false); - // X is 1-based, so X <= Length means we're within the line - if EndPos.X <= Length(LineText) then - Inc(EndPos.X) - else - begin - // Move to next line if already past end of current line (use 1-based indexing) - Inc(EndPos.Y); - EndPos.X := 1; - end; - end; + // Adjust EndPos for LSP Range specification (end position must be exclusive) + AdjustEndPosition(Node, EndPos); // clear existing symbols in symbol database // we don't know which include files are associated @@ -441,7 +1011,8 @@ procedure TSymbolExtractor.ExtractObjCClassMethods(ClassNode, Node: TCodeTreeNod var Child: TCodeTreeNode; ExternalClass: boolean = false; - TypeName: String; + TypeName, PropertyName, FieldName: String; + i: Integer; begin while Node <> nil do begin @@ -463,8 +1034,35 @@ procedure TSymbolExtractor.ExtractObjCClassMethods(ClassNode, Node: TCodeTreeNod end; end; ctnProcedure: + if not ShouldExcludeInterfaceDecl then begin - AddSymbol(Node, TSymbolKind._Method, Tool.ExtractProcName(Node, [])); + // Use Builder.AddMethod for consistent handling in both modes + TypeName := GetIdentifierAtPos(Tool, ClassNode.StartPos, true, true); + Builder.AddMethod(Node, TypeName, Tool.ExtractProcName(Node, [])); + end; + ctnProperty: + begin + // For property, skip the "property" keyword to get the actual property name + Tool.MoveCursorToCleanPos(Node.StartPos); + Tool.ReadNextAtom; // Skip "property" keyword + Tool.ReadNextAtom; // Move to property name + TypeName := GetIdentifierAtPos(Tool, ClassNode.StartPos, true, true); + // Extract property name from current atom + PropertyName := Copy(Tool.Scanner.CleanedSrc, Tool.CurPos.StartPos, + Tool.CurPos.EndPos - Tool.CurPos.StartPos); + Builder.AddProperty(Node, TypeName, PropertyName); + end; + ctnVarDefinition: + begin + // Extract field (class member variable) + TypeName := GetIdentifierAtPos(Tool, ClassNode.StartPos, true, true); + // For field, extract identifier without the colon + FieldName := GetIdentifierAtPos(Tool, Node.StartPos, true, true); + // Remove trailing colon if present + i := Pos(':', FieldName); + if i > 0 then + FieldName := Copy(FieldName, 1, i - 1); + Builder.AddField(Node, TypeName, FieldName); end; ctnClassPublic,ctnClassPublished,ctnClassPrivate,ctnClassProtected, ctnClassRequired,ctnClassOptional: @@ -478,9 +1076,17 @@ procedure TSymbolExtractor.ExtractObjCClassMethods(ClassNode, Node: TCodeTreeNod while Child <> nil do begin PrintNodeDebug(Child); - AddSymbol(Node, TSymbolKind._Method, TypeName+'.'+Tool.ExtractProcName(Child, [])); + if not ShouldExcludeInterfaceDecl then + AddSymbol(Node, TSymbolKind._Method, TypeName+'.'+Tool.ExtractProcName(Child, [])); Child := Child.NextBrother; end; + end + else + begin + // For regular Pascal classes, recurse into visibility sections + Inc(IndentLevel); + ExtractObjCClassMethods(ClassNode, Node.FirstChild); + Dec(IndentLevel); end; end; @@ -488,9 +1094,24 @@ procedure TSymbolExtractor.ExtractObjCClassMethods(ClassNode, Node: TCodeTreeNod end; end; -procedure TSymbolExtractor.ExtractTypeDefinition(TypeDefNode, Node: TCodeTreeNode); +// Helper to clean type name - removes trailing operators like '=' from 'TMyClass=' +function CleanTypeName(const AName: String): String; +var + Len: Integer; +const + OpChars = ['+', '*', '-', '/', '<', '>', '=', ':']; +begin + Result := AName; + Len := Length(Result); + while (Len > 0) and (Result[Len] in OpChars) do + Dec(Len); + SetLength(Result, Len); +end; + +procedure TSymbolExtractor.ExtractTypeDefinition(TypeDefNode, Node: TCodeTreeNode); var Child: TCodeTreeNode; + TypeName: String; begin while Node <> nil do begin @@ -499,16 +1120,36 @@ procedure TSymbolExtractor.ExtractTypeDefinition(TypeDefNode, Node: TCodeTreeNod case Node.Desc of ctnClass,ctnClassHelper,ctnRecordHelper,ctnTypeHelper: begin - AddSymbol(TypeDefNode, TSymbolKind._Class); + // Skip forward declarations (e.g., "TMyClass = class;") + // Use ctnsForwardDeclaration flag, not FirstChild check + // (empty class "TMyClass = class end;" has no children but is NOT forward) + if (Node.SubDesc and ctnsForwardDeclaration) > 0 then + begin + Node := Node.NextBrother; + continue; + end; + // Skip implementation class definitions when filter is enabled (smFlat mode only) + if ShouldExcludeImplClass then + begin + Node := Node.NextBrother; + continue; + end; + TypeName := CleanTypeName(GetIdentifierAtPos(Tool, TypeDefNode.StartPos, true, true)); + Builder.AddClass(TypeDefNode, TypeName); + Inc(IndentLevel); + ExtractObjCClassMethods(TypeDefNode, Node.FirstChild); + Dec(IndentLevel); end; ctnObject,ctnRecordType: begin - AddSymbol(TypeDefNode, TSymbolKind._Struct); + TypeName := CleanTypeName(GetIdentifierAtPos(Tool, TypeDefNode.StartPos, true, true)); + Builder.AddStruct(TypeDefNode, TypeName); end; ctnObjCClass,ctnObjCCategory,ctnObjCProtocol: begin // todo: ignore forward defs! - AddSymbol(TypeDefNode, TSymbolKind._Class); + TypeName := CleanTypeName(GetIdentifierAtPos(Tool, TypeDefNode.StartPos, true, true)); + Builder.AddClass(TypeDefNode, TypeName); Inc(IndentLevel); ExtractObjCClassMethods(TypeDefNode, Node.FirstChild); Dec(IndentLevel); @@ -517,7 +1158,8 @@ procedure TSymbolExtractor.ExtractTypeDefinition(TypeDefNode, Node: TCodeTreeNod begin // todo: is this a class/record??? PrintNodeDebug(Node.FirstChild, true); - AddSymbol(TypeDefNode, TSymbolKind._Class); + TypeName := CleanTypeName(GetIdentifierAtPos(Tool, TypeDefNode.StartPos, true, true)); + Builder.AddClass(TypeDefNode, TypeName); end; ctnEnumerationType: begin @@ -579,8 +1221,14 @@ function TSymbolExtractor.ExtractProcedure(ParentNode, Node: TCodeTreeNode):TSym end; end; - Symbol := AddSymbol(Node, TSymbolKind._Function, Name); - Symbol.containerName:=containerName; + // Create symbol for overload tracking metadata only + // Builder will handle actual addition to Entry.Symbols or FRootSymbols + Symbol := TSymbol.Create(nil); + Symbol.name := Name; + Symbol.kind := TSymbolKind._Function; + if containerName <> '' then + Symbol.containerName := TOptionalString.Create(containerName); + OverloadMap.Add(Key, Symbol); // recurse into procedures to find nested procedures @@ -603,9 +1251,40 @@ function TSymbolExtractor.ExtractProcedure(ParentNode, Node: TCodeTreeNode):TSym result := Symbol; end; -procedure TSymbolExtractor.ExtractCodeSection(Node: TCodeTreeNode); +procedure TSymbolExtractor.ProcessNestedFunctions(Node: TCodeTreeNode; ParentSymbol: TDocumentSymbolEx; const ParentPath: String); var - Symbol,LastClassSymbol: TSymbol; + Child: TCodeTreeNode; + NestedSymbol: TDocumentSymbolEx; + Name, NestedPath: String; +begin + // In hierarchical mode, we need a parent symbol for hierarchy + if (Builder.Mode = smHierarchical) and (ParentSymbol = nil) then + Exit; + + // Skip forward/external declarations + if Tool.ProcNodeHasSpecifier(Node, psForward) or + Tool.ProcNodeHasSpecifier(Node, psExternal) then + Exit; + + // Find nested procedures in the node's children + Child := Node.FirstChild; + while Child <> nil do + begin + if Child.Desc = ctnProcedure then + begin + Name := Tool.ExtractProcName(Child, [phpWithoutClassName]); + NestedSymbol := Builder.AddNestedFunction(ParentSymbol, Child, Name, ParentPath); + // Recursively process nested functions within this nested function + NestedPath := ParentPath + '.' + Name; + ProcessNestedFunctions(Child, NestedSymbol, NestedPath); + end; + Child := Child.NextBrother; + end; +end; + +procedure TSymbolExtractor.ExtractCodeSection(Node: TCodeTreeNode); +var + Symbol, MethodSymbol, LastClassSymbol: TSymbol; Child: TCodeTreeNode; Scanner: TLinkScanner; LinkIndex: Integer; @@ -636,9 +1315,23 @@ procedure TSymbolExtractor.ExtractCodeSection(Node: TCodeTreeNode); begin case Node.Desc of ctnInterface: - AddSymbol(Node, TSymbolKind._Namespace, kSymbolName_Interface); - //ctnImplementation: - // AddSymbol(Node, TSymbolKind._Namespace, kSymbolName_Implementation); + begin + // For hierarchical mode, create Interface namespace + Builder.BeginInterfaceSection(Node); + // For flat mode, add namespace symbol (unless filtered) + if Builder.Mode = smFlat then + if not TClientProfile.Current.HasFeature(cfExcludeSectionContainers) then + AddSymbol(Node, TSymbolKind._Namespace, kSymbolName_Interface); + end; + ctnImplementation: + begin + // For hierarchical mode, create Implementation namespace + Builder.BeginImplementationSection(Node); + // For flat mode, add namespace symbol (unless filtered) + if Builder.Mode = smFlat then + if not TClientProfile.Current.HasFeature(cfExcludeSectionContainers) then + AddSymbol(Node, TSymbolKind._Namespace, kSymbolName_Implementation); + end; end; CodeSection := Node.Desc; Inc(IndentLevel); @@ -688,16 +1381,40 @@ procedure TSymbolExtractor.ExtractCodeSection(Node: TCodeTreeNode); Symbol:= ExtractProcedure(nil, Node); - if (Symbol<>nil) and (Symbol.containerName<>'') then + if (Symbol<>nil) then begin - if (LastClassSymbol=nil) or (Symbol.containerName<>LastClassSymbol.name) then - begin - LastClassSymbol:=AddSymbol(Node,TSymbolKind._Class,Symbol.containerName); - end - else - begin - LastClassSymbol.location.range.&end:=Symbol.location.range.&end; - end; + // Use Builder to add methods or global functions based on containerName + if Assigned(Symbol.containerName) then + begin + // This is a class method + // Capture result to get the actual symbol with proper location + MethodSymbol := Builder.AddMethod(Node, Symbol.containerName.Value, Symbol.name); + // Process nested functions - parent path is ClassName.MethodName + ProcessNestedFunctions(Node, Builder.LastAddedFunction, + Symbol.containerName.Value + '.' + Symbol.name); + + // In flat mode, we also need to track class symbols for range updates + if (Builder.Mode = smFlat) and not ShouldExcludeImplClass then + begin + if (LastClassSymbol=nil) or (Symbol.containerName.Value<>LastClassSymbol.name) then + LastClassSymbol:=AddSymbol(Node,TSymbolKind._Class,Symbol.containerName.Value) + else if MethodSymbol <> nil then + LastClassSymbol.location.range.&end:=MethodSymbol.location.range.&end; + end; + end + else + begin + // This is a global function + // F1 Scheme: Add to current section's namespace + // - Interface section: function declaration + // - Implementation section: function implementation + if not ShouldExcludeInterfaceDecl then + begin + Builder.AddGlobalFunction(Node, Symbol.name); + // Process nested functions - parent path is function name + ProcessNestedFunctions(Node, Builder.LastAddedFunction, Symbol.name); + end; + end; end; end; @@ -712,12 +1429,15 @@ constructor TSymbolExtractor.Create(_Entry: TSymbolTableEntry; _Code: TCodeBuffe Entry := _Entry; Code := _Code; Tool := _Tool; + Builder := TSymbolBuilder.Create(Entry, Tool, GetSymbolMode); OverloadMap := TFPHashList.Create; RelatedFiles := TFPHashList.Create; end; -destructor TSymbolExtractor.Destroy; +destructor TSymbolExtractor.Destroy; begin + Builder.SerializeSymbols; + Builder.Free; OverloadMap.Free; RelatedFiles.Free; inherited; @@ -1223,10 +1943,12 @@ procedure TSymbolManager.Reload(Code: TCodeBuffer; Always: Boolean = false); try Extractor.ExtractCodeSection(Tool.Tree.Root); finally - Extractor.Free; + Extractor.Free; // This calls Builder.SerializeSymbols in the destructor end; - Entry.SerializeSymbols; + // Note: Entry.fRawJSON is already set by Builder.SerializeSymbols in Extractor.Destroy + // Don't call Entry.SerializeSymbols here as it would overwrite with flat format! + DoLog('Reloaded %s in %d ms', [Code.FileName, MilliSecondsBetween(Now,StartTime)]); end; diff --git a/src/serverprotocol/PasLS.Synchronization.pas b/src/serverprotocol/PasLS.Synchronization.pas index a854a3f..a5fd216 100644 --- a/src/serverprotocol/PasLS.Synchronization.pas +++ b/src/serverprotocol/PasLS.Synchronization.pas @@ -90,8 +90,8 @@ procedure TDidChangeTextDocument.Process(var Params : TDidChangeTextDocumentPara // Ryan, uncomment this to have a syntax check at // CheckSyntax(Self.Transport,Code); - //if SymbolManager <> nil then - // SymbolManager.FileModified(Code); + if SymbolManager <> nil then + SymbolManager.FileModified(Code); end; // DoLog( 'Synched text in %d ms',[MilliSecondsBetween(Now, StartTime)]); end; diff --git a/src/serverprotocol/PasLS.Workspace.pas b/src/serverprotocol/PasLS.Workspace.pas index 55a6246..7bfb692 100644 --- a/src/serverprotocol/PasLS.Workspace.pas +++ b/src/serverprotocol/PasLS.Workspace.pas @@ -81,7 +81,6 @@ procedure TDidChangeWorkspaceFolders.Process(var Params : TDidChangeWorkspaceFol function TWorkspaceSymbolRequest.DoExecute(const Params: TJSONData; AContext: TJSONRPCCallContext): TJSONData; var Input: TWorkspaceSymbolParams; - begin Input := specialize TLSPStreaming.ToObject(Params); Result := SymbolManager.FindWorkspaceSymbols(Input.query); diff --git a/src/serverprotocol/lspserver.lpk b/src/serverprotocol/lspserver.lpk index 332b634..8d9bf2f 100644 --- a/src/serverprotocol/lspserver.lpk +++ b/src/serverprotocol/lspserver.lpk @@ -138,6 +138,10 @@ + + + + diff --git a/src/serverprotocol/lspserver.pas b/src/serverprotocol/lspserver.pas index 1a0fb6c..f36114c 100644 --- a/src/serverprotocol/lspserver.pas +++ b/src/serverprotocol/lspserver.pas @@ -18,7 +18,7 @@ interface PasLS.DocumentSymbol, PasLS.Commands, PasLS.Formatter, PasLS.ExecuteCommand, PasLS.CodeUtils, PasLS.InvertAssign, PasLS.LazConfig, PasLS.Parser, PasLS.Symbols, PasLS.CheckInactiveRegions, PasLS.InactiveRegions, - LazarusPackageIntf; + PasLS.ClientProfile, LazarusPackageIntf; implementation diff --git a/src/tests/TestClassWithProperty.pas b/src/tests/TestClassWithProperty.pas new file mode 100644 index 0000000..ab1a8e1 --- /dev/null +++ b/src/tests/TestClassWithProperty.pas @@ -0,0 +1,31 @@ +unit TestClassWithProperty; + +{$mode objfpc}{$H+} + +interface + +type + TUser = class + private + FName: String; + FAge: Integer; + public + property Name: String read FName write FName; + property Age: Integer read FAge write FAge; + procedure PrintInfo; + function GetFullName: String; + end; + +implementation + +procedure TUser.PrintInfo; +begin + writeln('User: ', FName, ', Age: ', FAge); +end; + +function TUser.GetFullName: String; +begin + Result := FName; +end; + +end. diff --git a/src/tests/Tests.ClientProfile.pas b/src/tests/Tests.ClientProfile.pas new file mode 100644 index 0000000..13796a7 --- /dev/null +++ b/src/tests/Tests.ClientProfile.pas @@ -0,0 +1,261 @@ +unit Tests.ClientProfile; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpcunit, testregistry, + PasLS.ClientProfile; + +type + TTestClientProfile = class(TTestCase) + protected + procedure TearDown; override; + published + procedure TestTryStrToFeatureValidName; + procedure TestTryStrToFeatureInvalidName; + procedure TestFeatureToStr; + procedure TestAllFeaturesHaveNames; + procedure TestDefaultProfileHasNoFeatures; + procedure TestProfileWithFeatures; + procedure TestHasFeature; + procedure TestSelectRegisteredProfile; + procedure TestSelectUnknownProfileUsesDefault; + procedure TestCurrentReturnsDefault; + procedure TestApplyOverridesEnable; + procedure TestApplyOverridesDisable; + procedure TestApplyOverridesBothEnableAndDisable; + procedure TestApplyOverridesDoesNotModifyRegistry; + procedure TestSublimeTextHasExcludeSectionContainers; + procedure TestSublimeTextHasExcludeInterfaceMethodDecls; + procedure TestSublimeTextHasExcludeImplClassDefs; + end; + +implementation + +procedure TTestClientProfile.TestTryStrToFeatureValidName; +var + F: TClientFeature; +begin + AssertTrue('flatSymbolMode should parse', TryStrToFeature('flatSymbolMode', F)); + AssertEquals('flatSymbolMode parses to cfFlatSymbolMode', Ord(cfFlatSymbolMode), Ord(F)); + + AssertTrue('nullDocumentVersion should parse', TryStrToFeature('nullDocumentVersion', F)); + AssertEquals('nullDocumentVersion parses to cfNullDocumentVersion', Ord(cfNullDocumentVersion), Ord(F)); + + // Case insensitive + AssertTrue('FLATSYMBOLMODE should parse (case insensitive)', TryStrToFeature('FLATSYMBOLMODE', F)); + AssertEquals('Case insensitive parse', Ord(cfFlatSymbolMode), Ord(F)); +end; + +procedure TTestClientProfile.TestTryStrToFeatureInvalidName; +var + F: TClientFeature; +begin + AssertFalse('invalidFeature should not parse', TryStrToFeature('invalidFeature', F)); + AssertFalse('empty string should not parse', TryStrToFeature('', F)); + AssertFalse('random text should not parse', TryStrToFeature('someRandomText', F)); +end; + +procedure TTestClientProfile.TestFeatureToStr; +begin + AssertEquals('cfFlatSymbolMode', 'flatSymbolMode', FeatureToStr(cfFlatSymbolMode)); + AssertEquals('cfNullDocumentVersion', 'nullDocumentVersion', FeatureToStr(cfNullDocumentVersion)); + AssertEquals('cfFilterTextOnly', 'filterTextOnly', FeatureToStr(cfFilterTextOnly)); +end; + +procedure TTestClientProfile.TestAllFeaturesHaveNames; +var + F: TClientFeature; + ParsedFeature: TClientFeature; +begin + // Verify round-trip for all features + for F := Low(TClientFeature) to High(TClientFeature) do + begin + AssertTrue('Feature ' + IntToStr(Ord(F)) + ' should have parseable name', + TryStrToFeature(FeatureToStr(F), ParsedFeature)); + AssertEquals('Round-trip for feature ' + IntToStr(Ord(F)), + Ord(F), Ord(ParsedFeature)); + end; +end; + +procedure TTestClientProfile.TestDefaultProfileHasNoFeatures; +var + Profile: TClientProfile; +begin + Profile := TClientProfile.Create('TestDefault', []); + try + AssertEquals('Name should be TestDefault', 'TestDefault', Profile.Name); + AssertFalse('Empty profile has no cfFlatSymbolMode', Profile.HasFeature(cfFlatSymbolMode)); + AssertFalse('Empty profile has no cfNullDocumentVersion', Profile.HasFeature(cfNullDocumentVersion)); + finally + Profile.Free; + end; +end; + +procedure TTestClientProfile.TestProfileWithFeatures; +var + Profile: TClientProfile; +begin + Profile := TClientProfile.Create('TestWithFeatures', [cfFlatSymbolMode, cfNullDocumentVersion]); + try + AssertTrue('Profile has cfFlatSymbolMode', Profile.HasFeature(cfFlatSymbolMode)); + AssertTrue('Profile has cfNullDocumentVersion', Profile.HasFeature(cfNullDocumentVersion)); + AssertFalse('Profile does not have cfFilterTextOnly', Profile.HasFeature(cfFilterTextOnly)); + finally + Profile.Free; + end; +end; + +procedure TTestClientProfile.TestHasFeature; +var + Profile: TClientProfile; + F: TClientFeature; +begin + // Test with all features enabled + Profile := TClientProfile.Create('AllFeatures', [cfFlatSymbolMode..cfFilterTextOnly]); + try + for F := Low(TClientFeature) to High(TClientFeature) do + AssertTrue('All features should be present', Profile.HasFeature(F)); + finally + Profile.Free; + end; +end; + +procedure TTestClientProfile.TearDown; +begin + TClientProfile.SelectProfile(''); +end; + +procedure TTestClientProfile.TestSelectRegisteredProfile; +begin + // Sublime Text LSP is registered in initialization + TClientProfile.SelectProfile('Sublime Text LSP'); + AssertEquals('Selected Sublime Text profile', 'Sublime Text LSP', TClientProfile.Current.Name); + AssertTrue('Sublime has cfFlatSymbolMode', TClientProfile.Current.HasFeature(cfFlatSymbolMode)); +end; + +procedure TTestClientProfile.TestSelectUnknownProfileUsesDefault; +begin + TClientProfile.SelectProfile('UnknownClient'); + AssertEquals('Unknown client uses Default', 'Default', TClientProfile.Current.Name); + AssertFalse('Default has no cfFlatSymbolMode', TClientProfile.Current.HasFeature(cfFlatSymbolMode)); +end; + +procedure TTestClientProfile.TestCurrentReturnsDefault; +begin + // Reset by selecting empty string + TClientProfile.SelectProfile(''); + AssertNotNull('Current should not be nil', TClientProfile.Current); + AssertEquals('Current should be Default', 'Default', TClientProfile.Current.Name); +end; + +procedure TTestClientProfile.TestApplyOverridesEnable; +var + EnableList: TStringList; +begin + TClientProfile.SelectProfile('vscode'); + AssertFalse('VSCode has no cfFlatSymbolMode by default', + TClientProfile.Current.HasFeature(cfFlatSymbolMode)); + + EnableList := TStringList.Create; + try + EnableList.Add('flatSymbolMode'); + TClientProfile.ApplyOverrides(EnableList, nil); + AssertTrue('VSCode now has cfFlatSymbolMode after override', + TClientProfile.Current.HasFeature(cfFlatSymbolMode)); + finally + EnableList.Free; + end; +end; + +procedure TTestClientProfile.TestApplyOverridesDisable; +var + DisableList: TStringList; +begin + TClientProfile.SelectProfile('Sublime Text LSP'); + AssertTrue('Sublime has cfFlatSymbolMode by default', + TClientProfile.Current.HasFeature(cfFlatSymbolMode)); + + DisableList := TStringList.Create; + try + DisableList.Add('flatSymbolMode'); + TClientProfile.ApplyOverrides(nil, DisableList); + AssertFalse('Sublime no longer has cfFlatSymbolMode after override', + TClientProfile.Current.HasFeature(cfFlatSymbolMode)); + finally + DisableList.Free; + end; +end; + +procedure TTestClientProfile.TestApplyOverridesBothEnableAndDisable; +var + EnableList, DisableList: TStringList; +begin + TClientProfile.SelectProfile('vscode'); + + EnableList := TStringList.Create; + DisableList := TStringList.Create; + try + EnableList.Add('flatSymbolMode'); + EnableList.Add('nullDocumentVersion'); + DisableList.Add('flatSymbolMode'); // Disable takes precedence + + TClientProfile.ApplyOverrides(EnableList, DisableList); + + AssertFalse('Disable takes precedence over enable', + TClientProfile.Current.HasFeature(cfFlatSymbolMode)); + AssertTrue('nullDocumentVersion should be enabled', + TClientProfile.Current.HasFeature(cfNullDocumentVersion)); + finally + EnableList.Free; + DisableList.Free; + end; +end; + +procedure TTestClientProfile.TestApplyOverridesDoesNotModifyRegistry; +var + EnableList: TStringList; +begin + // First apply override + TClientProfile.SelectProfile('vscode'); + EnableList := TStringList.Create; + try + EnableList.Add('flatSymbolMode'); + TClientProfile.ApplyOverrides(EnableList, nil); + finally + EnableList.Free; + end; + + // Re-select the same profile - should get original features + TClientProfile.SelectProfile('vscode'); + AssertFalse('Re-selected profile should have original features', + TClientProfile.Current.HasFeature(cfFlatSymbolMode)); +end; + +procedure TTestClientProfile.TestSublimeTextHasExcludeSectionContainers; +begin + TClientProfile.SelectProfile('Sublime Text LSP'); + AssertTrue('Sublime has cfExcludeSectionContainers', + TClientProfile.Current.HasFeature(cfExcludeSectionContainers)); +end; + +procedure TTestClientProfile.TestSublimeTextHasExcludeInterfaceMethodDecls; +begin + TClientProfile.SelectProfile('Sublime Text LSP'); + AssertTrue('Sublime has cfExcludeInterfaceMethodDecls', + TClientProfile.Current.HasFeature(cfExcludeInterfaceMethodDecls)); +end; + +procedure TTestClientProfile.TestSublimeTextHasExcludeImplClassDefs; +begin + TClientProfile.SelectProfile('Sublime Text LSP'); + AssertTrue('Sublime has cfExcludeImplClassDefs', + TClientProfile.Current.HasFeature(cfExcludeImplClassDefs)); +end; + +initialization + RegisterTest(TTestClientProfile); + +end. diff --git a/src/tests/Tests.DocumentSymbol.pas b/src/tests/Tests.DocumentSymbol.pas new file mode 100644 index 0000000..0a2fba8 --- /dev/null +++ b/src/tests/Tests.DocumentSymbol.pas @@ -0,0 +1,1513 @@ +unit Tests.DocumentSymbol; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpcunit, testregistry, fpjson, jsonparser, + CodeToolManager, CodeCache, + PasLS.Symbols; + +type + + { TTestDocumentSymbol } + + TTestDocumentSymbol = class(TTestCase) + private + FTestCode: TCodeBuffer; + FTestFile: String; + procedure CreateTestFile(const AContent: String); + procedure CleanupTestFile; + protected + procedure SetUp; override; + procedure TearDown; override; + published + procedure TestSymbolExtractionHierarchical; + procedure TestSymbolExtractionFlat; + procedure TestForwardDeclarationSkipped; + procedure TestSelectionRangeHasNonZeroWidth; + procedure TestRangeValidity; + procedure TestSectionRangeExcludesNextSection; + procedure TestSymbolRangeExclusivity; + procedure TestProcedureRangeIncludesSemicolon; + procedure TestFlatModeRangeIncludesSemicolon; + procedure TestSingleLineSymbolRangeStaysOnSameLine; + procedure TestMethodSelectionRangePointsToName; + procedure TestHierarchicalModeFullValidation; + procedure TestFlatModeFullValidation; + end; + +implementation + +const + TEST_UNIT_WITH_PROPERTY_AND_FIELD = + 'unit TestUnit;' + LineEnding + + '' + LineEnding + + '{$mode objfpc}{$H+}' + LineEnding + + '' + LineEnding + + 'interface' + LineEnding + + '' + LineEnding + + 'type' + LineEnding + + ' TUser = class' + LineEnding + + ' private' + LineEnding + + ' FName: String;' + LineEnding + + ' FAge: Integer;' + LineEnding + + ' public' + LineEnding + + ' property Name: String read FName write FName;' + LineEnding + + ' property Age: Integer read FAge write FAge;' + LineEnding + + ' procedure PrintInfo;' + LineEnding + + ' function GetFullName: String;' + LineEnding + + ' end;' + LineEnding + + '' + LineEnding + + 'implementation' + LineEnding + + '' + LineEnding + + 'procedure TUser.PrintInfo;' + LineEnding + + 'begin' + LineEnding + + ' writeln(FName);' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + 'function TUser.GetFullName: String;' + LineEnding + + 'begin' + LineEnding + + ' Result := FName;' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + 'end.'; + + // Full test file for comprehensive position validation + // Based on test_symbols.pas structure + TEST_FULL_VALIDATION_FILE = + 'unit test_symbols;' + LineEnding + // line 0 + '' + LineEnding + // line 1 + '// Test file' + LineEnding + // line 2 + '' + LineEnding + // line 3 + '{$mode objfpc}{$H+}' + LineEnding + // line 4 + '' + LineEnding + // line 5 + 'interface' + LineEnding + // line 6 + '' + LineEnding + // line 7 + 'type' + LineEnding + // line 8 + ' TTestClassA = class' + LineEnding + // line 9: "TTestClassA" at 2-12 + ' private' + LineEnding + // line 10 + ' FValue: Integer;' + LineEnding + // line 11: "FValue" at 4-9 + ' public' + LineEnding + // line 12 + ' procedure MethodA1;' + LineEnding + // line 13: "MethodA1" at 14-21 + ' function MethodA2: Integer;' + LineEnding + // line 14: "MethodA2" at 13-20 + ' end;' + LineEnding + // line 15 + '' + LineEnding + // line 16 + 'procedure GlobalProc;' + LineEnding + // line 17: "GlobalProc" at 10-19 + '' + LineEnding + // line 18 + 'implementation' + LineEnding + // line 19 + '' + LineEnding + // line 20 + 'procedure TTestClassA.MethodA1;' + LineEnding + // line 21: "MethodA1" at 22-29 + 'var' + LineEnding + // line 22 + ' X: Integer;' + LineEnding + // line 23 + '' + LineEnding + // line 24 + ' procedure NestedProc;' + LineEnding + // line 25: "NestedProc" at 12-21 + ' begin' + LineEnding + // line 26 + ' X := 1;' + LineEnding + // line 27 + ' end;' + LineEnding + // line 28 + '' + LineEnding + // line 29 + 'begin' + LineEnding + // line 30 + ' NestedProc;' + LineEnding + // line 31 + 'end;' + LineEnding + // line 32 + '' + LineEnding + // line 33 + 'function TTestClassA.MethodA2: Integer;' + LineEnding + // line 34: "MethodA2" at 21-28 + 'begin' + LineEnding + // line 35 + ' Result := FValue;' + LineEnding + // line 36 + 'end;' + LineEnding + // line 37 + '' + LineEnding + // line 38 + 'procedure GlobalProc;' + LineEnding + // line 39: "GlobalProc" at 10-19 + 'begin' + LineEnding + // line 40 + 'end;' + LineEnding + // line 41 + '' + LineEnding + // line 42 + 'end.'; // line 43 + + // Test case for forward declarations - should be skipped in symbol extraction + TEST_UNIT_WITH_FORWARD_DECLARATION = + 'unit TestForward;' + LineEnding + + '' + LineEnding + + '{$mode objfpc}{$H+}' + LineEnding + + '' + LineEnding + + 'interface' + LineEnding + + '' + LineEnding + + 'type' + LineEnding + + ' // Forward class declaration - should be SKIPPED' + LineEnding + + ' TMySymbol = class;' + LineEnding + + '' + LineEnding + + ' // Helper class using the forward declared class' + LineEnding + + ' TSymbolHelper = class' + LineEnding + + ' private' + LineEnding + + ' FItem: TMySymbol;' + LineEnding + + ' public' + LineEnding + + ' procedure DoSomething;' + LineEnding + + ' end;' + LineEnding + + '' + LineEnding + + ' // Full class declaration - should be INCLUDED' + LineEnding + + ' TMySymbol = class' + LineEnding + + ' private' + LineEnding + + ' FName: String;' + LineEnding + + ' FKind: Integer;' + LineEnding + + ' public' + LineEnding + + ' property Name: String read FName write FName;' + LineEnding + + ' property Kind: Integer read FKind write FKind;' + LineEnding + + ' procedure Initialize;' + LineEnding + + ' end;' + LineEnding + + '' + LineEnding + + 'implementation' + LineEnding + + '' + LineEnding + + '{ TSymbolHelper }' + LineEnding + + '' + LineEnding + + 'procedure TSymbolHelper.DoSomething;' + LineEnding + + 'begin' + LineEnding + + ' FItem := nil;' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + '{ TMySymbol }' + LineEnding + + '' + LineEnding + + 'procedure TMySymbol.Initialize;' + LineEnding + + 'begin' + LineEnding + + ' FName := '''';' + LineEnding + + ' FKind := 0;' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + 'end.'; + +{ TTestDocumentSymbol } + +procedure TTestDocumentSymbol.CreateTestFile(const AContent: String); +var + F: TextFile; + ExistingBuffer: TCodeBuffer; +begin + FTestFile := GetTempFileName('', 'testunit'); + FTestFile := ChangeFileExt(FTestFile, '.pas'); + + AssignFile(F, FTestFile); + try + Rewrite(F); + Write(F, AContent); + finally + CloseFile(F); + end; + + // Force CodeToolBoss to reload from disk if buffer already exists + // This is necessary because GetTempFileName may reuse same filename + // after previous test deleted the file + ExistingBuffer := CodeToolBoss.FindFile(FTestFile); + if ExistingBuffer <> nil then + ExistingBuffer.Revert; +end; + +procedure TTestDocumentSymbol.CleanupTestFile; +begin + if FileExists(FTestFile) then + DeleteFile(FTestFile); + FTestFile := ''; +end; + +procedure TTestDocumentSymbol.SetUp; +begin + inherited SetUp; + FTestCode := nil; + FTestFile := ''; + + // Ensure SymbolManager is initialized + if SymbolManager = nil then + SymbolManager := TSymbolManager.Create; + + // Set hierarchical mode for tests + SetClientCapabilities(True); +end; + +procedure TTestDocumentSymbol.TearDown; +begin + CleanupTestFile; + FTestCode := nil; + inherited TearDown; +end; + +procedure TTestDocumentSymbol.TestSymbolExtractionHierarchical; +var + RawJSON: String; +begin + // Ensure hierarchical mode + SetClientCapabilities(True); + + // Create test file + CreateTestFile(TEST_UNIT_WITH_PROPERTY_AND_FIELD); + + // Load code buffer + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + + // Use SymbolManager to reload and extract symbols (public API) + SymbolManager.Reload(FTestCode, True); + + // Get the raw JSON from SymbolManager + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // Verify we extracted symbols + AssertTrue('Should have extracted symbols', RawJSON <> ''); + + // Verify the extracted symbols contain our expected names + AssertTrue('JSON should contain TUser class', Pos('"TUser"', RawJSON) > 0); + AssertTrue('JSON should contain FName field', Pos('FName', RawJSON) > 0); + AssertTrue('JSON should contain FAge field', Pos('FAge', RawJSON) > 0); + AssertTrue('JSON should contain Name property', Pos('"Name"', RawJSON) > 0); + AssertTrue('JSON should contain Age property', Pos('"Age"', RawJSON) > 0); + AssertTrue('JSON should contain PrintInfo method', Pos('PrintInfo', RawJSON) > 0); + AssertTrue('JSON should contain GetFullName method', Pos('GetFullName', RawJSON) > 0); + + // Check for hierarchical structure (children array) + AssertTrue('Should have children in hierarchical mode', Pos('"children"', RawJSON) > 0); + + // Check for correct symbol kinds (note: JSON has spaces around colons) + AssertTrue('Should have Class kind (5)', Pos('"kind" : 5', RawJSON) > 0); + AssertTrue('Should have Field kind (8)', Pos('"kind" : 8', RawJSON) > 0); + AssertTrue('Should have Property kind (7)', Pos('"kind" : 7', RawJSON) > 0); + AssertTrue('Should have Method kind (6)', Pos('"kind" : 6', RawJSON) > 0); +end; + +procedure TTestDocumentSymbol.TestSymbolExtractionFlat; +var + RawJSON: String; +begin + // Ensure flat mode + SetClientCapabilities(False); + + // Create test file + CreateTestFile(TEST_UNIT_WITH_PROPERTY_AND_FIELD); + + // Load code buffer + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + + // Use SymbolManager to reload and extract symbols (public API) + SymbolManager.Reload(FTestCode, True); + + // Get the raw JSON from SymbolManager + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // Verify we extracted symbols + AssertTrue('Should have extracted symbols', RawJSON <> ''); + + // Verify the extracted symbols contain our expected names + // In flat mode (smFlat), symbols use Class.Member naming (e.g., "TUser.Name") + AssertTrue('JSON should contain TUser class', Pos('"TUser"', RawJSON) > 0); + AssertTrue('JSON should contain TUser.FName field', Pos('TUser.FName', RawJSON) > 0); + AssertTrue('JSON should contain TUser.FAge field', Pos('TUser.FAge', RawJSON) > 0); + AssertTrue('JSON should contain TUser.Name property', Pos('TUser.Name', RawJSON) > 0); + AssertTrue('JSON should contain TUser.Age property', Pos('TUser.Age', RawJSON) > 0); + AssertTrue('JSON should contain TUser.PrintInfo method', Pos('TUser.PrintInfo', RawJSON) > 0); + AssertTrue('JSON should contain TUser.GetFullName method', Pos('TUser.GetFullName', RawJSON) > 0); + + // In flat mode, should NOT have children array + AssertTrue('Should NOT have children in flat mode', Pos('"children"', RawJSON) = 0); + + // In flat mode (smFlat), should NOT have containerName (uses Class.Member naming instead) + AssertTrue('Should NOT have containerName in flat mode', Pos('"containerName"', RawJSON) = 0); + + // Check for correct symbol kinds (note: JSON has spaces around colons) + AssertTrue('Should have Class kind (5)', Pos('"kind" : 5', RawJSON) > 0); + AssertTrue('Should have Field kind (8)', Pos('"kind" : 8', RawJSON) > 0); + AssertTrue('Should have Property kind (7)', Pos('"kind" : 7', RawJSON) > 0); + AssertTrue('Should have Method kind (6)', Pos('"kind" : 6', RawJSON) > 0); +end; + +procedure TTestDocumentSymbol.TestForwardDeclarationSkipped; +var + RawJSON: String; +begin + // Test forward declarations are skipped + // Forward declaration "TMySymbol = class;" at line 8 should NOT appear + // Full declaration "TMySymbol = class" at line 19 SHOULD appear + + SetClientCapabilities(True); // hierarchical mode + + // Create test file with forward declarations + CreateTestFile(TEST_UNIT_WITH_FORWARD_DECLARATION); + + // Load code buffer + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + + // Use SymbolManager to reload and extract symbols + SymbolManager.Reload(FTestCode, True); + + // Get the raw JSON from SymbolManager + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // Verify we extracted symbols + AssertTrue('Should have extracted symbols', RawJSON <> ''); + + // Forward declaration is at line 8 (0-indexed) + // If forward declaration was NOT skipped, we'd see "line" : 8 for TMySymbol + // Check that line 8 does NOT appear in the JSON (no symbol starts at that line) + AssertTrue('Forward declaration at line 8 should be skipped', + Pos('"start" : { "character" : 2, "line" : 8', RawJSON) = 0); + + // Full declaration is at line 19, should appear + AssertTrue('Full declaration at line 19 should be present', + Pos('"start" : { "character" : 2, "line" : 19', RawJSON) > 0); + + // Verify child members exist (proves full declaration was extracted, not forward) + AssertTrue('Should contain FName field', Pos('FName', RawJSON) > 0); + AssertTrue('Should contain FKind field', Pos('FKind', RawJSON) > 0); + AssertTrue('Should contain Name property', Pos('"Name"', RawJSON) > 0); +end; + +procedure TTestDocumentSymbol.TestSelectionRangeHasNonZeroWidth; +var + RawJSON: String; +begin + // Test that selectionRange has non-zero width (end.character > start.character) + // This is required for proper symbol selection in editors like Sublime Text + // See: https://github.com/anthropics/claude-code/issues/XXX + // + // Previously, selectionRange was set to zero-width: + // "selectionRange" : { "start" : { "character" : 2, "line" : 7 }, "end" : { "character" : 2, "line" : 7 } } + // Now it should span the symbol name: + // "selectionRange" : { "start" : { "character" : 2, "line" : 7 }, "end" : { "character" : 7, "line" : 7 } } + // (for a 5-character symbol name like "TUser") + + SetClientCapabilities(True); // hierarchical mode + + // Create test file + CreateTestFile(TEST_UNIT_WITH_PROPERTY_AND_FIELD); + + // Load code buffer + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + + // Use SymbolManager to reload and extract symbols + SymbolManager.Reload(FTestCode, True); + + // Get the raw JSON from SymbolManager + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // TUser is at line 7 (0-indexed), character 2 + // TUser has 5 characters, so selectionRange.end.character should be 2 + 5 = 7 + // Check that selectionRange has proper width (not zero-width) + AssertTrue('TUser selectionRange should have width 5 (end.char=7)', + Pos('"selectionRange" : { "end" : { "character" : 7, "line" : 7 }, "start" : { "character" : 2, "line" : 7 } }', RawJSON) > 0); + + // FName field is at line 9 (0-indexed), character 4 + // FName has 5 characters, so selectionRange.end.character should be 4 + 5 = 9 + AssertTrue('FName selectionRange should have width 5 (end.char=9)', + Pos('"selectionRange" : { "end" : { "character" : 9, "line" : 9 }, "start" : { "character" : 4, "line" : 9 } }', RawJSON) > 0); +end; + +procedure TTestDocumentSymbol.TestRangeValidity; + + function IsValidRange(const RangeObj: TJSONObject): Boolean; + var + StartObj, EndObj: TJSONObject; + StartLine, StartChar, EndLine, EndChar: Integer; + begin + Result := False; + if RangeObj = nil then Exit; + + StartObj := RangeObj.FindPath('start') as TJSONObject; + EndObj := RangeObj.FindPath('end') as TJSONObject; + if (StartObj = nil) or (EndObj = nil) then Exit; + + StartLine := StartObj.Get('line', -1); + StartChar := StartObj.Get('character', -1); + EndLine := EndObj.Get('line', -1); + EndChar := EndObj.Get('character', -1); + + // All values must be non-negative + if (StartLine < 0) or (StartChar < 0) or (EndLine < 0) or (EndChar < 0) then + Exit; + + // End must be >= Start + if EndLine < StartLine then Exit; + if (EndLine = StartLine) and (EndChar < StartChar) then Exit; + + Result := True; + end; + + procedure ValidateSymbolRanges(const SymbolArray: TJSONArray; const Mode: String); + var + I: Integer; + Symbol: TJSONObject; + RangeObj, LocationObj: TJSONObject; + SymbolName: String; + begin + for I := 0 to SymbolArray.Count - 1 do + begin + Symbol := SymbolArray.Items[I] as TJSONObject; + SymbolName := Symbol.Get('name', ''); + + // Hierarchical mode: check 'range' and 'selectionRange' + RangeObj := Symbol.FindPath('range') as TJSONObject; + if RangeObj <> nil then + begin + AssertTrue(Format('%s: Symbol "%s" has invalid range', [Mode, SymbolName]), + IsValidRange(RangeObj)); + end; + + RangeObj := Symbol.FindPath('selectionRange') as TJSONObject; + if RangeObj <> nil then + begin + AssertTrue(Format('%s: Symbol "%s" has invalid selectionRange', [Mode, SymbolName]), + IsValidRange(RangeObj)); + end; + + // Flat mode: check 'location.range' + LocationObj := Symbol.FindPath('location') as TJSONObject; + if LocationObj <> nil then + begin + RangeObj := LocationObj.FindPath('range') as TJSONObject; + if RangeObj <> nil then + begin + AssertTrue(Format('%s: Symbol "%s" has invalid location.range', [Mode, SymbolName]), + IsValidRange(RangeObj)); + end; + end; + + // Recursively check children (hierarchical mode) + if Symbol.FindPath('children') is TJSONArray then + ValidateSymbolRanges(Symbol.FindPath('children') as TJSONArray, Mode); + end; + end; + +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray: TJSONArray; +begin + // Test hierarchical mode + SetClientCapabilities(True); + CreateTestFile(TEST_UNIT_WITH_FORWARD_DECLARATION); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + ValidateSymbolRanges(SymbolArray, 'Hierarchical'); + finally + JSONData.Free; + end; + + CleanupTestFile; + + // Test flat mode + SetClientCapabilities(False); + CreateTestFile(TEST_UNIT_WITH_FORWARD_DECLARATION); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded (flat)', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array (flat)', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + ValidateSymbolRanges(SymbolArray, 'Flat'); + finally + JSONData.Free; + end; +end; + +procedure TTestDocumentSymbol.TestSectionRangeExcludesNextSection; +{ Test that interface section's range does NOT include the implementation line. + This verifies the fix for SetNodeRange applying section-node adjustment. + Interface range.end.line should be < implementation range.start.line } +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray: TJSONArray; + I: Integer; + Symbol, RangeObj, EndObj: TJSONObject; + SymbolName: String; + InterfaceFound, ImplementationFound: Boolean; + InterfaceEndLine, ImplementationStartLine: Integer; +begin + // Test hierarchical mode + SetClientCapabilities(True); + CreateTestFile(TEST_UNIT_WITH_FORWARD_DECLARATION); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + + InterfaceFound := False; + ImplementationFound := False; + InterfaceEndLine := -1; + ImplementationStartLine := -1; + + // Find interface and implementation section symbols + for I := 0 to SymbolArray.Count - 1 do + begin + Symbol := SymbolArray.Items[I] as TJSONObject; + SymbolName := Symbol.Get('name', ''); + + if SymbolName = 'interface' then + begin + InterfaceFound := True; + RangeObj := Symbol.FindPath('range') as TJSONObject; + AssertNotNull('Interface should have range', RangeObj); + EndObj := RangeObj.FindPath('end') as TJSONObject; + AssertNotNull('Interface range should have end', EndObj); + InterfaceEndLine := EndObj.Get('line', -1); + end + else if SymbolName = 'implementation' then + begin + ImplementationFound := True; + RangeObj := Symbol.FindPath('range') as TJSONObject; + AssertNotNull('Implementation should have range', RangeObj); + RangeObj := RangeObj.FindPath('start') as TJSONObject; + AssertNotNull('Implementation range should have start', RangeObj); + ImplementationStartLine := RangeObj.Get('line', -1); + end; + end; + + AssertTrue('Interface section should be found', InterfaceFound); + AssertTrue('Implementation section should be found', ImplementationFound); + + // The key assertion: interface end line must be LESS than implementation start line + // This ensures sections don't overlap and interface doesn't include implementation keyword + AssertTrue( + Format('Interface end line (%d) should be < implementation start line (%d)', + [InterfaceEndLine, ImplementationStartLine]), + InterfaceEndLine < ImplementationStartLine); + + finally + JSONData.Free; + end; +end; + +procedure TTestDocumentSymbol.TestProcedureRangeIncludesSemicolon; +{ Test that procedure/function range.end position is correct for LSP. + The range should include the trailing semicolon, meaning: + - range.end points PAST the semicolon (exclusive end) + - The character at (range.end.line, range.end.character - 1) should be ';' + + This test catches the ";;" bug where replace_symbol_body duplicates semicolons + because the range doesn't include the original semicolon. } +const + TEST_SIMPLE_PROCEDURE = + 'unit TestProc;' + LineEnding + // line 0 + '' + LineEnding + // line 1 + 'interface' + LineEnding + // line 2 + '' + LineEnding + // line 3 + 'implementation' + LineEnding + // line 4 + '' + LineEnding + // line 5 + 'procedure DoSomething;' + LineEnding + // line 6 + 'begin' + LineEnding + // line 7 + ' writeln(''test'');' + LineEnding + // line 8 + 'end;' + LineEnding + // line 9: "end;" at cols 0-3, ';' at col 3 + '' + LineEnding + // line 10 + 'end.'; // line 11 +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray: TJSONArray; + Children: TJSONArray; + I, J: Integer; + Symbol, RangeObj, EndObj: TJSONObject; + SymbolName: String; + EndLine, EndChar: Integer; + SourceLines: TStringList; + LastIncludedChar: Char; + ProcFound: Boolean; +begin + // Test hierarchical mode + SetClientCapabilities(True); + CreateTestFile(TEST_SIMPLE_PROCEDURE); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // Parse source to verify character positions + SourceLines := TStringList.Create; + try + SourceLines.Text := TEST_SIMPLE_PROCEDURE; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + + ProcFound := False; + + // Find the DoSomething procedure (look in implementation children) + for I := 0 to SymbolArray.Count - 1 do + begin + Symbol := SymbolArray.Items[I] as TJSONObject; + SymbolName := Symbol.Get('name', ''); + + // Look for the procedure in implementation section children + if SymbolName = 'implementation' then + begin + Children := Symbol.FindPath('children') as TJSONArray; + if Children <> nil then + for J := 0 to Children.Count - 1 do + begin + Symbol := Children.Items[J] as TJSONObject; + SymbolName := Symbol.Get('name', ''); + if SymbolName = 'DoSomething' then + begin + ProcFound := True; + RangeObj := Symbol.FindPath('range') as TJSONObject; + AssertNotNull('Procedure should have range', RangeObj); + EndObj := RangeObj.FindPath('end') as TJSONObject; + AssertNotNull('Range should have end', EndObj); + EndLine := EndObj.Get('line', -1); + EndChar := EndObj.Get('character', -1); + + // Verify we can access the source line + AssertTrue(Format('EndLine %d should be valid', [EndLine]), + (EndLine >= 0) and (EndLine < SourceLines.Count)); + AssertTrue(Format('EndChar %d should be > 0 for exclusive end', [EndChar]), + EndChar > 0); + + // The character just before the exclusive end should be ';' + // EndChar is 0-indexed, exclusive, so EndChar-1 is the last included char + if EndChar <= Length(SourceLines[EndLine]) then + LastIncludedChar := SourceLines[EndLine][EndChar] // EndChar is 0-indexed, string is 1-indexed + else + // EndChar points past line end, check previous char on same line + LastIncludedChar := SourceLines[EndLine][Length(SourceLines[EndLine])]; + + AssertEquals( + Format('Last included char at line %d, col %d should be semicolon. ' + + 'Line content: "%s"', [EndLine, EndChar-1, SourceLines[EndLine]]), + ';', LastIncludedChar); + + Break; + end; + end; + end; + if ProcFound then Break; + end; + + AssertTrue('DoSomething procedure should be found', ProcFound); + + finally + JSONData.Free; + end; + finally + SourceLines.Free; + end; +end; + +procedure TTestDocumentSymbol.TestFlatModeRangeIncludesSemicolon; +{ Test that SymbolInformation (flat mode) location.range.end includes semicolon. + This is critical for Serena's replace_symbol_body to work correctly. + + Bug history: AddFlatSymbol was not calling AdjustEndPositionForLSP, + causing location.range.end.character to point AT the semicolon instead + of PAST it, resulting in double semicolons when replacing symbol bodies. } +const + TEST_SIMPLE_PROCEDURE = + 'unit TestProc;' + LineEnding + // line 0 + '' + LineEnding + // line 1 + 'interface' + LineEnding + // line 2 + '' + LineEnding + // line 3 + 'implementation' + LineEnding + // line 4 + '' + LineEnding + // line 5 + 'procedure DoSomething;' + LineEnding + // line 6 + 'begin' + LineEnding + // line 7 + ' writeln(''test'');' + LineEnding + // line 8 + 'end;' + LineEnding + // line 9: "end;" at cols 0-3, ';' at col 3 + '' + LineEnding + // line 10 + 'end.'; // line 11 +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray: TJSONArray; + I: Integer; + Symbol, LocationObj, RangeObj, EndObj: TJSONObject; + SymbolName: String; + EndLine, EndChar: Integer; + SourceLines: TStringList; + LastIncludedChar: Char; + ProcFound: Boolean; +begin + // Test flat mode (SymbolInformation format with location.range) + SetClientCapabilities(False); + CreateTestFile(TEST_SIMPLE_PROCEDURE); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // Parse source to verify character positions + SourceLines := TStringList.Create; + try + SourceLines.Text := TEST_SIMPLE_PROCEDURE; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + + ProcFound := False; + + // In flat mode, symbols are at root level with location.range + for I := 0 to SymbolArray.Count - 1 do + begin + Symbol := SymbolArray.Items[I] as TJSONObject; + SymbolName := Symbol.Get('name', ''); + + // Find DoSomething procedure + if SymbolName = 'DoSomething' then + begin + ProcFound := True; + + // Flat mode uses location.range instead of range + LocationObj := Symbol.FindPath('location') as TJSONObject; + AssertNotNull('Procedure should have location', LocationObj); + RangeObj := LocationObj.FindPath('range') as TJSONObject; + AssertNotNull('Location should have range', RangeObj); + EndObj := RangeObj.FindPath('end') as TJSONObject; + AssertNotNull('Range should have end', EndObj); + EndLine := EndObj.Get('line', -1); + EndChar := EndObj.Get('character', -1); + + // Verify we can access the source line + AssertTrue(Format('EndLine %d should be valid', [EndLine]), + (EndLine >= 0) and (EndLine < SourceLines.Count)); + AssertTrue(Format('EndChar %d should be > 0 for exclusive end', [EndChar]), + EndChar > 0); + + // The character just before the exclusive end should be ';' + // EndChar is 0-indexed, exclusive, so EndChar-1 is the last included char + // In Pascal 1-indexed string: EndChar maps to the last included char + if EndChar <= Length(SourceLines[EndLine]) then + LastIncludedChar := SourceLines[EndLine][EndChar] + else + LastIncludedChar := SourceLines[EndLine][Length(SourceLines[EndLine])]; + + AssertEquals( + Format('Flat mode: Last included char at line %d, col %d should be semicolon. ' + + 'Line content: "%s", EndChar: %d', + [EndLine, EndChar-1, SourceLines[EndLine], EndChar]), + ';', LastIncludedChar); + + Break; + end; + end; + + AssertTrue('DoSomething procedure should be found in flat mode', ProcFound); + + finally + JSONData.Free; + end; + finally + SourceLines.Free; + end; +end; + +procedure TTestDocumentSymbol.TestSingleLineSymbolRangeStaysOnSameLine; +{ Test that single-line symbols (fields, properties, method declarations) + have range.start.line == range.end.line. + + Bug history: AdjustEndPositionForLSP incorrectly moved to next line when + EndPos.X > Length(LineText), causing single-line symbols like "FName: String;" + to have range extending to the next line. This caused incorrect highlighting + in VS Code which uses range (not selectionRange) for symbol highlighting. + + Fix: Keep EndPos on same line by setting EndPos.X := Length(LineText) + 1 + instead of Inc(EndPos.Y); EndPos.X := 1; } + + procedure CheckSingleLineSymbol(const Symbol: TJSONObject; const Mode: String); + var + SymbolName: String; + RangeObj, StartObj, EndObj, LocationObj: TJSONObject; + StartLine, EndLine: Integer; + Children: TJSONArray; + I: Integer; + begin + SymbolName := Symbol.Get('name', ''); + + // Get range (hierarchical mode) or location.range (flat mode) + RangeObj := Symbol.FindPath('range') as TJSONObject; + if RangeObj = nil then + begin + LocationObj := Symbol.FindPath('location') as TJSONObject; + if LocationObj <> nil then + RangeObj := LocationObj.FindPath('range') as TJSONObject; + end; + + if RangeObj <> nil then + begin + StartObj := RangeObj.FindPath('start') as TJSONObject; + EndObj := RangeObj.FindPath('end') as TJSONObject; + if (StartObj <> nil) and (EndObj <> nil) then + begin + StartLine := StartObj.Get('line', -1); + EndLine := EndObj.Get('line', -1); + + // For field symbols (kind=8), they should be single-line + // FName and FAge are fields that must stay on same line + if (SymbolName = 'FName') or (SymbolName = 'FAge') then + begin + AssertEquals( + Format('%s: Field "%s" range must stay on same line', [Mode, SymbolName]), + StartLine, EndLine); + end; + end; + end; + + // Recursively check children + Children := Symbol.FindPath('children') as TJSONArray; + if Children <> nil then + for I := 0 to Children.Count - 1 do + CheckSingleLineSymbol(Children.Items[I] as TJSONObject, Mode); + end; + +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray: TJSONArray; + I: Integer; +begin + // Test hierarchical mode (the mode where bug was observed) + SetClientCapabilities(True); + CreateTestFile(TEST_UNIT_WITH_PROPERTY_AND_FIELD); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + for I := 0 to SymbolArray.Count - 1 do + CheckSingleLineSymbol(SymbolArray.Items[I] as TJSONObject, 'Hierarchical'); + finally + JSONData.Free; + end; + + CleanupTestFile; + + // Test flat mode as well + SetClientCapabilities(False); + CreateTestFile(TEST_UNIT_WITH_PROPERTY_AND_FIELD); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded (flat)', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array (flat)', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + for I := 0 to SymbolArray.Count - 1 do + CheckSingleLineSymbol(SymbolArray.Items[I] as TJSONObject, 'Flat'); + finally + JSONData.Free; + end; +end; + +procedure TTestDocumentSymbol.TestSymbolRangeExclusivity; +{ Test that range.end is exclusive for all symbol types: + class, method, procedure, function, property, field. + For multi-line symbols: end.line > start.line + For single-line symbols: end.character > start.character + Also verifies selectionRange has non-zero width } + + function GetRangeInfo(const RangeObj: TJSONObject; out StartLine, StartChar, EndLine, EndChar: Integer): Boolean; + var + StartObj, EndObj: TJSONObject; + begin + Result := False; + if RangeObj = nil then Exit; + StartObj := RangeObj.FindPath('start') as TJSONObject; + EndObj := RangeObj.FindPath('end') as TJSONObject; + if (StartObj = nil) or (EndObj = nil) then Exit; + StartLine := StartObj.Get('line', -1); + StartChar := StartObj.Get('character', -1); + EndLine := EndObj.Get('line', -1); + EndChar := EndObj.Get('character', -1); + Result := (StartLine >= 0) and (StartChar >= 0) and (EndLine >= 0) and (EndChar >= 0); + end; + + procedure CheckSymbolRange(const Symbol: TJSONObject; const Mode: String); + var + SymbolName: String; + SymbolKind: Integer; + RangeObj, SelRangeObj, LocationObj: TJSONObject; + StartLine, StartChar, EndLine, EndChar: Integer; + SelStartLine, SelStartChar, SelEndLine, SelEndChar: Integer; + Children: TJSONArray; + I: Integer; + begin + SymbolName := Symbol.Get('name', ''); + SymbolKind := Symbol.Get('kind', 0); + + // Get range (hierarchical mode) or location.range (flat mode) + RangeObj := Symbol.FindPath('range') as TJSONObject; + if RangeObj = nil then + begin + LocationObj := Symbol.FindPath('location') as TJSONObject; + if LocationObj <> nil then + RangeObj := LocationObj.FindPath('range') as TJSONObject; + end; + + if RangeObj <> nil then + begin + if GetRangeInfo(RangeObj, StartLine, StartChar, EndLine, EndChar) then + begin + // Range must have positive extent + if EndLine = StartLine then + AssertTrue(Format('%s: Symbol "%s" (kind %d) range on same line must have end.char > start.char', + [Mode, SymbolName, SymbolKind]), EndChar > StartChar) + else + AssertTrue(Format('%s: Symbol "%s" (kind %d) multi-line range must have end.line >= start.line', + [Mode, SymbolName, SymbolKind]), EndLine >= StartLine); + end; + end; + + // Check selectionRange (hierarchical mode only) + SelRangeObj := Symbol.FindPath('selectionRange') as TJSONObject; + if SelRangeObj <> nil then + begin + if GetRangeInfo(SelRangeObj, SelStartLine, SelStartChar, SelEndLine, SelEndChar) then + begin + // selectionRange should have non-zero width (typically same line) + if SelEndLine = SelStartLine then + AssertTrue(Format('%s: Symbol "%s" selectionRange must have width > 0', + [Mode, SymbolName]), SelEndChar > SelStartChar); + + // selectionRange must be contained within range + if RangeObj <> nil then + begin + AssertTrue(Format('%s: Symbol "%s" selectionRange.start must be >= range.start', + [Mode, SymbolName]), + (SelStartLine > StartLine) or ((SelStartLine = StartLine) and (SelStartChar >= StartChar))); + AssertTrue(Format('%s: Symbol "%s" selectionRange.end must be <= range.end', + [Mode, SymbolName]), + (SelEndLine < EndLine) or ((SelEndLine = EndLine) and (SelEndChar <= EndChar))); + end; + end; + end; + + // Recursively check children + Children := Symbol.FindPath('children') as TJSONArray; + if Children <> nil then + for I := 0 to Children.Count - 1 do + CheckSymbolRange(Children.Items[I] as TJSONObject, Mode); + end; + +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray: TJSONArray; + I: Integer; +begin + // Test hierarchical mode + SetClientCapabilities(True); + CreateTestFile(TEST_UNIT_WITH_PROPERTY_AND_FIELD); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + for I := 0 to SymbolArray.Count - 1 do + CheckSymbolRange(SymbolArray.Items[I] as TJSONObject, 'Hierarchical'); + finally + JSONData.Free; + end; + + CleanupTestFile; + + // Test flat mode + SetClientCapabilities(False); + CreateTestFile(TEST_UNIT_WITH_PROPERTY_AND_FIELD); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded (flat)', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array (flat)', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + for I := 0 to SymbolArray.Count - 1 do + CheckSymbolRange(SymbolArray.Items[I] as TJSONObject, 'Flat'); + finally + JSONData.Free; + end; +end; + +procedure TTestDocumentSymbol.TestMethodSelectionRangePointsToName; +{ Test that selectionRange for methods points to the method NAME, not the + "procedure"/"function" keyword. + + Bug history: SetNodeRange used Node.StartPos which for procedure nodes + points to the "procedure" keyword. This caused selectionRange to highlight + "procedure" instead of "MethodA1" in editors like Sublime Text. + + Fix: Use MoveCursorToProcName to find the actual name position. } +const + TEST_METHOD_SELECTION = + 'unit TestMethod;' + LineEnding + // line 0 + '' + LineEnding + // line 1 + 'interface' + LineEnding + // line 2 + '' + LineEnding + // line 3 + 'type' + LineEnding + // line 4 + ' TMyClass = class' + LineEnding + // line 5 + ' procedure DoWork;' + LineEnding + // line 6: "procedure" at 4, "DoWork" at 14 + ' function Calculate: Integer;' + LineEnding + // line 7: "function" at 4, "Calculate" at 13 + ' end;' + LineEnding + // line 8 + '' + LineEnding + // line 9 + 'implementation' + LineEnding + // line 10 + '' + LineEnding + // line 11 + 'procedure TMyClass.DoWork;' + LineEnding + // line 12: "procedure" at 0, "DoWork" at 19 + 'begin' + LineEnding + // line 13 + 'end;' + LineEnding + // line 14 + '' + LineEnding + // line 15 + 'function TMyClass.Calculate: Integer;' + LineEnding + // line 16: "function" at 0, "Calculate" at 18 + 'begin' + LineEnding + // line 17 + ' Result := 42;' + LineEnding + // line 18 + 'end;' + LineEnding + // line 19 + '' + LineEnding + // line 20 + 'end.'; // line 21 +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray, Children, ClassChildren: TJSONArray; + I, J, K: Integer; + Symbol, ChildSymbol, MethodSymbol, SelRangeObj, StartObj: TJSONObject; + SymbolName: String; + SelStartChar: Integer; + DoWorkFoundInterface, CalculateFoundInterface: Boolean; + DoWorkFoundImpl, CalculateFoundImpl: Boolean; +begin + // Test hierarchical mode + SetClientCapabilities(True); + CreateTestFile(TEST_METHOD_SELECTION); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + DoWorkFoundInterface := False; + CalculateFoundInterface := False; + DoWorkFoundImpl := False; + CalculateFoundImpl := False; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + + // Find methods in interface (class declaration) and implementation + for I := 0 to SymbolArray.Count - 1 do + begin + Symbol := SymbolArray.Items[I] as TJSONObject; + SymbolName := Symbol.Get('name', ''); + + // Check interface section - class with method declarations + if SymbolName = 'interface' then + begin + Children := Symbol.FindPath('children') as TJSONArray; + if Children <> nil then + for J := 0 to Children.Count - 1 do + begin + ChildSymbol := Children.Items[J] as TJSONObject; + if ChildSymbol.Get('name', '') = 'TMyClass' then + begin + // Find methods inside class + ClassChildren := ChildSymbol.FindPath('children') as TJSONArray; + if ClassChildren <> nil then + for K := 0 to ClassChildren.Count - 1 do + begin + MethodSymbol := ClassChildren.Items[K] as TJSONObject; + SymbolName := MethodSymbol.Get('name', ''); + + SelRangeObj := MethodSymbol.FindPath('selectionRange') as TJSONObject; + if SelRangeObj <> nil then + begin + StartObj := SelRangeObj.FindPath('start') as TJSONObject; + if StartObj <> nil then + begin + SelStartChar := StartObj.Get('character', -1); + + if SymbolName = 'DoWork' then + begin + DoWorkFoundInterface := True; + // Line 6: " procedure DoWork;" + // "DoWork" starts at char 14, not char 4 (where "procedure" starts) + AssertEquals( + 'Interface DoWork selectionRange.start.character should point to name', + 14, SelStartChar); + end + else if SymbolName = 'Calculate' then + begin + CalculateFoundInterface := True; + // Line 7: " function Calculate: Integer;" + // "Calculate" starts at char 13, not char 4 (where "function" starts) + AssertEquals( + 'Interface Calculate selectionRange.start.character should point to name', + 13, SelStartChar); + end; + end; + end; + end; + Break; + end; + end; + end + + // Check implementation section - class method implementations + else if SymbolName = 'implementation' then + begin + Children := Symbol.FindPath('children') as TJSONArray; + if Children <> nil then + for J := 0 to Children.Count - 1 do + begin + ChildSymbol := Children.Items[J] as TJSONObject; + if ChildSymbol.Get('name', '') = 'TMyClass' then + begin + // Find methods inside implementation class container + ClassChildren := ChildSymbol.FindPath('children') as TJSONArray; + if ClassChildren <> nil then + for K := 0 to ClassChildren.Count - 1 do + begin + MethodSymbol := ClassChildren.Items[K] as TJSONObject; + SymbolName := MethodSymbol.Get('name', ''); + + SelRangeObj := MethodSymbol.FindPath('selectionRange') as TJSONObject; + if SelRangeObj <> nil then + begin + StartObj := SelRangeObj.FindPath('start') as TJSONObject; + if StartObj <> nil then + begin + SelStartChar := StartObj.Get('character', -1); + + if SymbolName = 'DoWork' then + begin + DoWorkFoundImpl := True; + // Line 12: "procedure TMyClass.DoWork;" + // "DoWork" starts at char 19, not char 0 (where "procedure" starts) + AssertEquals( + 'Implementation DoWork selectionRange.start.character should point to name', + 19, SelStartChar); + end + else if SymbolName = 'Calculate' then + begin + CalculateFoundImpl := True; + // Line 16: "function TMyClass.Calculate: Integer;" + // "Calculate" starts at char 18, not char 0 (where "function" starts) + AssertEquals( + 'Implementation Calculate selectionRange.start.character should point to name', + 18, SelStartChar); + end; + end; + end; + end; + Break; + end; + end; + end; + end; + + AssertTrue('DoWork should be found in interface', DoWorkFoundInterface); + AssertTrue('Calculate should be found in interface', CalculateFoundInterface); + AssertTrue('DoWork should be found in implementation', DoWorkFoundImpl); + AssertTrue('Calculate should be found in implementation', CalculateFoundImpl); + + finally + JSONData.Free; + end; +end; + +procedure TTestDocumentSymbol.TestHierarchicalModeFullValidation; +{ Comprehensive test for hierarchical mode (DocumentSymbol[]). + Validates exact line and character positions for all symbols. + Uses TEST_FULL_VALIDATION_FILE which has precise position comments. + + Expected symbol hierarchy: + - interface (line 6) + - TTestClassA (line 9) + - FValue (line 11) + - MethodA1 (line 13) + - MethodA2 (line 14) + - GlobalProc (line 17) + - implementation (line 19) + - TTestClassA (container for methods) + - MethodA1 (line 21) + - NestedProc (line 25) + - MethodA2 (line 34) + - GlobalProc (line 39) +} + + procedure CheckSelectionRange(Symbol: TJSONObject; const SymbolName: String; + ExpStartLine, ExpStartChar, ExpEndLine, ExpEndChar: Integer); + var + SelRange, StartObj, EndObj: TJSONObject; + ActStartLine, ActStartChar, ActEndLine, ActEndChar: Integer; + begin + SelRange := Symbol.FindPath('selectionRange') as TJSONObject; + AssertNotNull(Format('%s should have selectionRange', [SymbolName]), SelRange); + + StartObj := SelRange.FindPath('start') as TJSONObject; + EndObj := SelRange.FindPath('end') as TJSONObject; + AssertNotNull(Format('%s selectionRange should have start', [SymbolName]), StartObj); + AssertNotNull(Format('%s selectionRange should have end', [SymbolName]), EndObj); + + ActStartLine := StartObj.Get('line', -1); + ActStartChar := StartObj.Get('character', -1); + ActEndLine := EndObj.Get('line', -1); + ActEndChar := EndObj.Get('character', -1); + + AssertEquals(Format('%s selectionRange.start.line', [SymbolName]), ExpStartLine, ActStartLine); + AssertEquals(Format('%s selectionRange.start.character', [SymbolName]), ExpStartChar, ActStartChar); + AssertEquals(Format('%s selectionRange.end.line', [SymbolName]), ExpEndLine, ActEndLine); + AssertEquals(Format('%s selectionRange.end.character', [SymbolName]), ExpEndChar, ActEndChar); + end; + + function FindSymbolByName(Arr: TJSONArray; const Name: String): TJSONObject; + var + I: Integer; + Obj: TJSONObject; + begin + Result := nil; + if Arr = nil then Exit; + for I := 0 to Arr.Count - 1 do + begin + Obj := Arr.Items[I] as TJSONObject; + if Obj.Get('name', '') = Name then + Exit(Obj); + end; + end; + +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray, InterfaceChildren, ImplChildren, ClassChildren, MethodChildren: TJSONArray; + InterfaceSymbol, ImplSymbol, ClassSymbol, MethodSymbol, NestedSymbol: TJSONObject; +begin + // Test hierarchical mode + SetClientCapabilities(True); + CreateTestFile(TEST_FULL_VALIDATION_FILE); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + + // Find interface section + InterfaceSymbol := FindSymbolByName(SymbolArray, 'interface'); + AssertNotNull('Interface symbol should exist', InterfaceSymbol); + // "interface" at line 6, char 0-8 (length 9) + CheckSelectionRange(InterfaceSymbol, 'interface', 6, 0, 6, 9); + + // Check interface children + InterfaceChildren := InterfaceSymbol.FindPath('children') as TJSONArray; + AssertNotNull('Interface should have children', InterfaceChildren); + + // TTestClassA in interface at line 9 + // " TTestClassA = class" -> "TTestClassA" at char 2-12 (length 11) + ClassSymbol := FindSymbolByName(InterfaceChildren, 'TTestClassA'); + AssertNotNull('TTestClassA should exist in interface', ClassSymbol); + CheckSelectionRange(ClassSymbol, 'interface.TTestClassA', 9, 2, 9, 13); + + ClassChildren := ClassSymbol.FindPath('children') as TJSONArray; + AssertNotNull('TTestClassA should have children', ClassChildren); + + // FValue at line 11: " FValue: Integer;" -> "FValue" at char 4-9 (length 6) + MethodSymbol := FindSymbolByName(ClassChildren, 'FValue'); + AssertNotNull('FValue should exist', MethodSymbol); + CheckSelectionRange(MethodSymbol, 'FValue', 11, 4, 11, 10); + + // MethodA1 at line 13: " procedure MethodA1;" -> "MethodA1" at char 14-21 (length 8) + MethodSymbol := FindSymbolByName(ClassChildren, 'MethodA1'); + AssertNotNull('MethodA1 should exist in interface', MethodSymbol); + CheckSelectionRange(MethodSymbol, 'interface.MethodA1', 13, 14, 13, 22); + + // MethodA2 at line 14: " function MethodA2: Integer;" -> "MethodA2" at char 13-20 (length 8) + MethodSymbol := FindSymbolByName(ClassChildren, 'MethodA2'); + AssertNotNull('MethodA2 should exist in interface', MethodSymbol); + CheckSelectionRange(MethodSymbol, 'interface.MethodA2', 14, 13, 14, 21); + + // GlobalProc at line 17: "procedure GlobalProc;" -> "GlobalProc" at char 10-19 (length 10) + MethodSymbol := FindSymbolByName(InterfaceChildren, 'GlobalProc'); + AssertNotNull('GlobalProc should exist in interface', MethodSymbol); + CheckSelectionRange(MethodSymbol, 'interface.GlobalProc', 17, 10, 17, 20); + + // Find implementation section + ImplSymbol := FindSymbolByName(SymbolArray, 'implementation'); + AssertNotNull('Implementation symbol should exist', ImplSymbol); + // "implementation" at line 19, char 0-13 (length 14) + CheckSelectionRange(ImplSymbol, 'implementation', 19, 0, 19, 14); + + ImplChildren := ImplSymbol.FindPath('children') as TJSONArray; + AssertNotNull('Implementation should have children', ImplChildren); + + // TTestClassA container in implementation + ClassSymbol := FindSymbolByName(ImplChildren, 'TTestClassA'); + AssertNotNull('TTestClassA should exist in implementation', ClassSymbol); + + ClassChildren := ClassSymbol.FindPath('children') as TJSONArray; + AssertNotNull('TTestClassA impl should have children', ClassChildren); + + // MethodA1 implementation at line 21: "procedure TTestClassA.MethodA1;" + // "MethodA1" at char 22-29 (length 8) + MethodSymbol := FindSymbolByName(ClassChildren, 'MethodA1'); + AssertNotNull('MethodA1 should exist in implementation', MethodSymbol); + CheckSelectionRange(MethodSymbol, 'impl.MethodA1', 21, 22, 21, 30); + + // Check nested function: NestedProc at line 25 + // " procedure NestedProc;" -> "NestedProc" at char 12-21 (length 10) + MethodChildren := MethodSymbol.FindPath('children') as TJSONArray; + AssertNotNull('MethodA1 should have children (nested)', MethodChildren); + NestedSymbol := FindSymbolByName(MethodChildren, 'NestedProc'); + AssertNotNull('NestedProc should exist', NestedSymbol); + CheckSelectionRange(NestedSymbol, 'NestedProc', 25, 12, 25, 22); + + // MethodA2 implementation at line 34: "function TTestClassA.MethodA2: Integer;" + // "MethodA2" at char 21-28 (length 8) + MethodSymbol := FindSymbolByName(ClassChildren, 'MethodA2'); + AssertNotNull('MethodA2 should exist in implementation', MethodSymbol); + CheckSelectionRange(MethodSymbol, 'impl.MethodA2', 34, 21, 34, 29); + + // GlobalProc implementation at line 39: "procedure GlobalProc;" + // "GlobalProc" at char 10-19 (length 10) + MethodSymbol := FindSymbolByName(ImplChildren, 'GlobalProc'); + AssertNotNull('GlobalProc should exist in implementation', MethodSymbol); + CheckSelectionRange(MethodSymbol, 'impl.GlobalProc', 39, 10, 39, 20); + + finally + JSONData.Free; + end; +end; + +procedure TTestDocumentSymbol.TestFlatModeFullValidation; +{ Comprehensive test for flat mode (SymbolInformation[]). + Validates exact line and character positions for all symbols via location.range. + Uses TEST_FULL_VALIDATION_FILE which has precise position comments. + + In flat mode, symbols have location.range (not range/selectionRange). + The range should span from symbol start to end (inclusive of semicolon). +} + + procedure CheckLocationRange(Symbol: TJSONObject; const SymbolName: String; + ExpStartLine, ExpStartChar: Integer); + var + Location, RangeObj, StartObj: TJSONObject; + ActStartLine, ActStartChar: Integer; + begin + Location := Symbol.FindPath('location') as TJSONObject; + AssertNotNull(Format('%s should have location', [SymbolName]), Location); + + RangeObj := Location.FindPath('range') as TJSONObject; + AssertNotNull(Format('%s location should have range', [SymbolName]), RangeObj); + + StartObj := RangeObj.FindPath('start') as TJSONObject; + AssertNotNull(Format('%s range should have start', [SymbolName]), StartObj); + + ActStartLine := StartObj.Get('line', -1); + ActStartChar := StartObj.Get('character', -1); + + AssertEquals(Format('%s location.range.start.line', [SymbolName]), ExpStartLine, ActStartLine); + AssertEquals(Format('%s location.range.start.character', [SymbolName]), ExpStartChar, ActStartChar); + end; + + function FindSymbolByName(Arr: TJSONArray; const Name: String): TJSONObject; + var + I: Integer; + Obj: TJSONObject; + begin + Result := nil; + if Arr = nil then Exit; + for I := 0 to Arr.Count - 1 do + begin + Obj := Arr.Items[I] as TJSONObject; + if Obj.Get('name', '') = Name then + Exit(Obj); + end; + end; + +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray: TJSONArray; + Symbol: TJSONObject; +begin + // Test flat mode + SetClientCapabilities(False); + CreateTestFile(TEST_FULL_VALIDATION_FILE); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + + // In flat mode, symbols use ClassName.MemberName naming + // Check interface section symbol + Symbol := FindSymbolByName(SymbolArray, 'interface'); + AssertNotNull('interface symbol should exist', Symbol); + CheckLocationRange(Symbol, 'interface', 6, 0); + + // TTestClassA at line 9 + Symbol := FindSymbolByName(SymbolArray, 'TTestClassA'); + AssertNotNull('TTestClassA should exist', Symbol); + CheckLocationRange(Symbol, 'TTestClassA', 9, 2); + + // TTestClassA.FValue at line 11 (flat mode uses Class.Member naming) + Symbol := FindSymbolByName(SymbolArray, 'TTestClassA.FValue'); + AssertNotNull('TTestClassA.FValue should exist', Symbol); + CheckLocationRange(Symbol, 'TTestClassA.FValue', 11, 4); + + // TTestClassA.MethodA1 at line 13 (interface declaration) + Symbol := FindSymbolByName(SymbolArray, 'TTestClassA.MethodA1'); + AssertNotNull('TTestClassA.MethodA1 should exist', Symbol); + CheckLocationRange(Symbol, 'TTestClassA.MethodA1', 13, 4); + + // TTestClassA.MethodA2 at line 14 (interface declaration) + Symbol := FindSymbolByName(SymbolArray, 'TTestClassA.MethodA2'); + AssertNotNull('TTestClassA.MethodA2 should exist', Symbol); + CheckLocationRange(Symbol, 'TTestClassA.MethodA2', 14, 4); + + // GlobalProc at line 17 + Symbol := FindSymbolByName(SymbolArray, 'GlobalProc'); + AssertNotNull('GlobalProc should exist', Symbol); + CheckLocationRange(Symbol, 'GlobalProc', 17, 0); + + // implementation section symbol + Symbol := FindSymbolByName(SymbolArray, 'implementation'); + AssertNotNull('implementation symbol should exist', Symbol); + CheckLocationRange(Symbol, 'implementation', 19, 0); + + // Note: In flat mode, implementation methods have different positions + // because they start with "procedure TClassName.MethodName" + // MethodA1 at line 21 is now a method (not TTestClassA.MethodA1 duplicate) + // The overloadPolicy setting determines how duplicates are handled + + finally + JSONData.Free; + end; +end; + +initialization + RegisterTest(TTestDocumentSymbol); +end. diff --git a/src/tests/Tests.SublimeProfile.pas b/src/tests/Tests.SublimeProfile.pas new file mode 100644 index 0000000..09cee85 --- /dev/null +++ b/src/tests/Tests.SublimeProfile.pas @@ -0,0 +1,659 @@ +unit Tests.SublimeProfile; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpcunit, testregistry, fpjson, jsonparser, + CodeToolManager, CodeCache, + PasLS.Symbols, PasLS.ClientProfile; + +type + + { TTestSublimeProfile } + + TTestSublimeProfile = class(TTestCase) + private + FTestFile: String; + FTestCode: TCodeBuffer; + procedure CreateTestFile(const AContent: String); + procedure CleanupTestFile; + function GetSymbolNames(const RawJSON: String): TStringList; + function HasSymbol(const Names: TStringList; const SymbolName: String): Boolean; + function CountSymbol(const Names: TStringList; const SymbolName: String): Integer; + protected + procedure SetUp; override; + procedure TearDown; override; + published + procedure TestFlatModeHasLocation; + procedure TestFlatModeNoChildren; + procedure TestFlatModeMethodNaming; + procedure TestFlatModeNoContainerName; + procedure TestNoInterfaceContainer; + procedure TestNoImplementationContainer; + procedure TestClassesAtTopLevel; + procedure TestNoInterfaceMethodDecls; + procedure TestPreservesInterfaceClassDefs; + procedure TestNoInterfaceGlobalFuncDecl; + procedure TestNoImplClassDefs; + procedure TestNoDuplicateClasses; + procedure TestNoForwardDeclarations; + procedure TestImplClassMethodsPreserved; + procedure TestCompareWithDefault; + procedure TestGlobalFuncPreserved; + procedure TestNestedProcPreserved; + end; + +implementation + +const + TEST_SUBLIME_UNIT = + 'unit TestUnit;' + LineEnding + + '' + LineEnding + + '{$mode objfpc}{$H+}' + LineEnding + + '' + LineEnding + + 'interface' + LineEnding + // line 4 + '' + LineEnding + + 'type' + LineEnding + + ' TForward = class;' + LineEnding + // line 7: forward declaration + '' + LineEnding + + ' TMyClass = class' + LineEnding + // line 9 + ' procedure MethodA;' + LineEnding + // line 10 + ' function MethodB: Integer;' + LineEnding + // line 11 + ' end;' + LineEnding + + '' + LineEnding + + ' TMyRecord = record' + LineEnding + // line 14 + ' Field1: Integer;' + LineEnding + + ' end;' + LineEnding + + '' + LineEnding + + 'function GlobalFunc: Boolean;' + LineEnding + // line 18 + '' + LineEnding + + 'implementation' + LineEnding + // line 20 + '' + LineEnding + + 'type' + LineEnding + + ' TImplOnlyClass = class' + LineEnding + // line 23: impl-only class + ' procedure ImplMethod;' + LineEnding + + ' end;' + LineEnding + + '' + LineEnding + + '{ TMyClass }' + LineEnding + + '' + LineEnding + + 'procedure TMyClass.MethodA;' + LineEnding + // line 29 + '' + LineEnding + + ' procedure NestedProc;' + LineEnding + // line 31 + ' begin' + LineEnding + + ' end;' + LineEnding + + '' + LineEnding + + 'begin' + LineEnding + + ' NestedProc;' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + 'function TMyClass.MethodB: Integer;' + LineEnding + // line 39 + 'begin' + LineEnding + + ' Result := 0;' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + '{ TImplOnlyClass }' + LineEnding + + '' + LineEnding + + 'procedure TImplOnlyClass.ImplMethod;' + LineEnding + // line 46 + 'begin' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + '{ Global }' + LineEnding + + '' + LineEnding + + 'function GlobalFunc: Boolean;' + LineEnding + // line 52 + 'begin' + LineEnding + + ' Result := True;' + LineEnding + + 'end;' + LineEnding + + '' + LineEnding + + 'end.'; + +{ TTestSublimeProfile } + +procedure TTestSublimeProfile.CreateTestFile(const AContent: String); +var + F: TextFile; + ExistingBuffer: TCodeBuffer; +begin + FTestFile := GetTempFileName('', 'testunit'); + FTestFile := ChangeFileExt(FTestFile, '.pas'); + + AssignFile(F, FTestFile); + try + Rewrite(F); + Write(F, AContent); + finally + CloseFile(F); + end; + + ExistingBuffer := CodeToolBoss.FindFile(FTestFile); + if ExistingBuffer <> nil then + ExistingBuffer.Revert; +end; + +procedure TTestSublimeProfile.CleanupTestFile; +begin + if FileExists(FTestFile) then + DeleteFile(FTestFile); + FTestFile := ''; +end; + +procedure TTestSublimeProfile.SetUp; +begin + inherited SetUp; + FTestCode := nil; + FTestFile := ''; + + if SymbolManager = nil then + SymbolManager := TSymbolManager.Create; +end; + +procedure TTestSublimeProfile.TearDown; +begin + CleanupTestFile; + TClientProfile.SelectProfile(''); // Reset to default + inherited TearDown; +end; + +function TTestSublimeProfile.GetSymbolNames(const RawJSON: String): TStringList; + + procedure CollectNames(const Arr: TJSONArray; Names: TStringList); + var + I: Integer; + Obj: TJSONObject; + Children: TJSONArray; + SymbolName: String; + begin + for I := 0 to Arr.Count - 1 do + begin + Obj := Arr.Items[I] as TJSONObject; + SymbolName := Obj.Get('name', ''); + if SymbolName <> '' then + Names.Add(SymbolName); + + // Check for hierarchical children + if Obj.FindPath('children') is TJSONArray then + begin + Children := Obj.FindPath('children') as TJSONArray; + CollectNames(Children, Names); + end; + end; + end; + +var + JSONData: TJSONData; +begin + Result := TStringList.Create; + Result.Sorted := True; + Result.Duplicates := dupAccept; + + JSONData := GetJSON(RawJSON); + try + if JSONData is TJSONArray then + CollectNames(JSONData as TJSONArray, Result); + finally + JSONData.Free; + end; +end; + +function TTestSublimeProfile.HasSymbol(const Names: TStringList; const SymbolName: String): Boolean; +begin + Result := Names.IndexOf(SymbolName) >= 0; +end; + +function TTestSublimeProfile.CountSymbol(const Names: TStringList; const SymbolName: String): Integer; +var + I: Integer; +begin + Result := 0; + for I := 0 to Names.Count - 1 do + if Names[I] = SymbolName then + Inc(Result); +end; + +procedure TTestSublimeProfile.TestFlatModeHasLocation; +var + RawJSON: String; +begin + // F1.1: Sublime profile uses SymbolInformation[] with location field + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // SymbolInformation has "location" field, DocumentSymbol has "range" + AssertTrue('Should have location field (flat mode)', + Pos('"location"', RawJSON) > 0); +end; + +procedure TTestSublimeProfile.TestFlatModeNoChildren; +var + RawJSON: String; +begin + // F1.2: Flat mode should NOT have children field + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + AssertTrue('Should NOT have children field in flat mode', + Pos('"children"', RawJSON) = 0); +end; + +procedure TTestSublimeProfile.TestFlatModeMethodNaming; +var + RawJSON: String; + Names: TStringList; +begin + // F1.3: Methods should be named as "ClassName.MethodName" + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + AssertTrue('Should have TMyClass.MethodA', + HasSymbol(Names, 'TMyClass.MethodA')); + AssertTrue('Should have TMyClass.MethodB', + HasSymbol(Names, 'TMyClass.MethodB')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestFlatModeNoContainerName; +var + RawJSON: String; +begin + // F1.4: Flat mode should NOT have containerName field (Lazarus style) + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // SymbolInformation typically has containerName, but Lazarus style uses + // ClassName.MethodName in the name field instead + AssertTrue('Should NOT have containerName field', + Pos('"containerName"', RawJSON) = 0); +end; + +procedure TTestSublimeProfile.TestNoInterfaceContainer; +var + RawJSON: String; + Names: TStringList; +begin + // S1.1: Sublime profile excludes "interface" container symbol + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + AssertFalse('Should NOT have "interface" container', + HasSymbol(Names, 'interface')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestNoImplementationContainer; +var + RawJSON: String; + Names: TStringList; +begin + // S1.2: Sublime profile excludes "implementation" container symbol + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + AssertFalse('Should NOT have "implementation" container', + HasSymbol(Names, 'implementation')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestClassesAtTopLevel; +var + RawJSON: String; + JSONData: TJSONData; + SymbolArray: TJSONArray; + I: Integer; + Obj: TJSONObject; + FoundTMyClass: Boolean; +begin + // S1.3: Classes should appear at top level (not nested under section containers) + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + JSONData := GetJSON(RawJSON); + try + AssertTrue('Result should be an array', JSONData is TJSONArray); + SymbolArray := JSONData as TJSONArray; + + // TMyClass should be directly in the top-level array + FoundTMyClass := False; + for I := 0 to SymbolArray.Count - 1 do + begin + Obj := SymbolArray.Items[I] as TJSONObject; + if Obj.Get('name', '') = 'TMyClass' then + begin + FoundTMyClass := True; + Break; + end; + end; + + AssertTrue('TMyClass should be at top level (not nested)', FoundTMyClass); + finally + JSONData.Free; + end; +end; + +procedure TTestSublimeProfile.TestNoInterfaceMethodDecls; +var + RawJSON: String; + Names: TStringList; +begin + // M1.1: Sublime profile excludes interface method declarations + // But keeps the implementation methods (TMyClass.MethodA, TMyClass.MethodB) + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + // Should have implementation methods + AssertTrue('Should have TMyClass.MethodA (impl)', + HasSymbol(Names, 'TMyClass.MethodA')); + AssertTrue('Should have TMyClass.MethodB (impl)', + HasSymbol(Names, 'TMyClass.MethodB')); + + // In flat mode with cfExcludeInterfaceMethodDecls: + // Interface declarations (bare MethodA, MethodB) should not appear + // Only the implementation versions (TMyClass.MethodA) should exist + // Count how many times the method appears - should be exactly once + // (the implementation version, not the interface declaration) + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestPreservesInterfaceClassDefs; +var + RawJSON: String; + Names: TStringList; +begin + // M1.2: Sublime profile keeps interface class definitions + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + AssertTrue('Should have TMyClass (interface class)', + HasSymbol(Names, 'TMyClass')); + AssertTrue('Should have TMyRecord (interface record)', + HasSymbol(Names, 'TMyRecord')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestNoInterfaceGlobalFuncDecl; +var + RawJSON: String; + Names: TStringList; +begin + // M1.4: Interface GlobalFunc declaration should be excluded + // Only the implementation version should exist (exactly 1 occurrence) + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + // GlobalFunc should appear exactly once (implementation only) + // Not twice (interface declaration + implementation) + AssertEquals('GlobalFunc should appear exactly once', + 1, CountSymbol(Names, 'GlobalFunc')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestNoImplClassDefs; +var + RawJSON: String; + Names: TStringList; +begin + // C1.1: Sublime profile excludes implementation-only class definitions + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + // TImplOnlyClass is defined only in implementation section + // It should NOT appear as a class symbol + AssertFalse('TImplOnlyClass should NOT exist (impl-only class)', + HasSymbol(Names, 'TImplOnlyClass')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestNoDuplicateClasses; +var + RawJSON: String; + Names: TStringList; +begin + // C1.4: Each class should appear exactly once (no duplicates) + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + // TMyClass should appear exactly once + // (not twice from interface + implementation) + AssertEquals('TMyClass should appear exactly once', + 1, CountSymbol(Names, 'TMyClass')); + + // TMyRecord should appear exactly once + AssertEquals('TMyRecord should appear exactly once', + 1, CountSymbol(Names, 'TMyRecord')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestNoForwardDeclarations; +var + RawJSON: String; + Names: TStringList; +begin + // C1.5: Forward declarations should be excluded + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + // TForward is a forward declaration at line 7 + AssertFalse('TForward should NOT exist (forward declaration)', + HasSymbol(Names, 'TForward')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestImplClassMethodsPreserved; +var + RawJSON: String; + Names: TStringList; +begin + // C1.6: Methods of impl-only classes should still appear + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + // TImplOnlyClass.ImplMethod should exist even though + // TImplOnlyClass class symbol is excluded + AssertTrue('TImplOnlyClass.ImplMethod should exist', + HasSymbol(Names, 'TImplOnlyClass.ImplMethod')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestCompareWithDefault; +var + SublimeJSON, DefaultJSON: String; + SublimeNames, DefaultNames: TStringList; +begin + // Compare Sublime profile output with Default profile + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + + // Get Sublime profile symbols + TClientProfile.SelectProfile('Sublime Text LSP'); + SymbolManager.Reload(FTestCode, True); + SublimeJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + // Get Default profile symbols (hierarchical mode) + TClientProfile.SelectProfile(''); // Reset to default + SetClientCapabilities(True); // Hierarchical mode + SymbolManager.Reload(FTestCode, True); + DefaultJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + SublimeNames := GetSymbolNames(SublimeJSON); + DefaultNames := GetSymbolNames(DefaultJSON); + try + // Default has section containers, Sublime doesn't + AssertTrue('Default has interface', HasSymbol(DefaultNames, 'interface')); + AssertFalse('Sublime has no interface', HasSymbol(SublimeNames, 'interface')); + + AssertTrue('Default has implementation', HasSymbol(DefaultNames, 'implementation')); + AssertFalse('Sublime has no implementation', HasSymbol(SublimeNames, 'implementation')); + + // Default has hierarchical children, Sublime doesn't + AssertTrue('Default JSON has children', Pos('"children"', DefaultJSON) > 0); + AssertTrue('Sublime JSON has no children', Pos('"children"', SublimeJSON) = 0); + finally + SublimeNames.Free; + DefaultNames.Free; + end; +end; + +procedure TTestSublimeProfile.TestGlobalFuncPreserved; +var + RawJSON: String; + Names: TStringList; +begin + // Global functions in implementation should be preserved + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + // GlobalFunc implementation at line 52 should exist + AssertTrue('GlobalFunc should exist (implementation)', + HasSymbol(Names, 'GlobalFunc')); + finally + Names.Free; + end; +end; + +procedure TTestSublimeProfile.TestNestedProcPreserved; +var + RawJSON: String; + Names: TStringList; +begin + // Nested procedures should be preserved with proper naming + TClientProfile.SelectProfile('Sublime Text LSP'); + + CreateTestFile(TEST_SUBLIME_UNIT); + FTestCode := CodeToolBoss.LoadFile(FTestFile, True, False); + AssertNotNull('Code buffer should be loaded', FTestCode); + SymbolManager.Reload(FTestCode, True); + RawJSON := SymbolManager.FindDocumentSymbols(FTestFile).AsJSON; + + Names := GetSymbolNames(RawJSON); + try + // NestedProc inside TMyClass.MethodA should exist + // In flat mode: TMyClass.MethodA.NestedProc + AssertTrue('TMyClass.MethodA.NestedProc should exist', + HasSymbol(Names, 'TMyClass.MethodA.NestedProc')); + finally + Names.Free; + end; +end; + +initialization + RegisterTest(TTestSublimeProfile); + +end. diff --git a/src/tests/test_program.lpr b/src/tests/test_program.lpr new file mode 100644 index 0000000..22d6558 --- /dev/null +++ b/src/tests/test_program.lpr @@ -0,0 +1,126 @@ +program test_program; + +// ============================================================================= +// Test file for LSP DocumentSymbol in program files (.lpr/.dpr) +// Program files don't have interface/implementation sections +// ============================================================================= + +{$mode objfpc}{$H+} + +uses + SysUtils, Classes; + +type + { TTestClass } + TTestClass = class + private + FValue: Integer; + public + procedure TestMethod1; + function TestMethod2: Integer; + end; + + { TTestClass2 - Second test class } + TTestClass2 = class + private + FName: String; + public + procedure MethodA; + procedure MethodB; + end; + + { TTestRecord - Test record type } + TTestRecord = record + X, Y: Integer; + Name: String; + end; + +{ TTestClass } + +procedure TTestClass.TestMethod1; +var + LocalVar: Integer; + + procedure NestedProc; + begin + LocalVar := 1; + end; + +begin + // Test point 1: cursor here should show breadcrumb: TTestClass > TestMethod1 + NestedProc; +end; + +function TTestClass.TestMethod2: Integer; +begin + // Test point 2: cursor here should show breadcrumb: TTestClass > TestMethod2 + Result := FValue; +end; + +{ TTestClass2 } + +procedure TTestClass2.MethodA; +begin + // Test point 3: cursor here should show breadcrumb: TTestClass2 > MethodA + FName := 'Hello'; +end; + +procedure TTestClass2.MethodB; +var + Temp: Integer; + + function NestedFunc: Integer; + begin + Result := 42; + end; + +begin + // Test point 4: cursor here should show breadcrumb: TTestClass2 > MethodB + Temp := NestedFunc; + FName := FName + IntToStr(Temp); +end; + +{ Global Functions } + +procedure GlobalProc; +var + I: Integer; + + procedure NestedInGlobal; + begin + I := 42; + end; + +begin + // Test point 5: cursor here should show breadcrumb: GlobalProc + NestedInGlobal; +end; + +function GlobalFunc(Value: Integer): Integer; +begin + // Test point 6: cursor here should show breadcrumb: GlobalFunc + Result := Value * 2; +end; + +var + TestObj: TTestClass; + TestObj2: TTestClass2; + TestRec: TTestRecord; + +begin + TestObj := TTestClass.Create; + TestObj2 := TTestClass2.Create; + try + TestObj.TestMethod1; + WriteLn(TestObj.TestMethod2); + TestObj2.MethodA; + TestObj2.MethodB; + GlobalProc; + WriteLn(GlobalFunc(10)); + TestRec.X := 1; + TestRec.Y := 2; + finally + TestObj.Free; + TestObj2.Free; + end; +end. diff --git a/src/tests/test_symbols.pas b/src/tests/test_symbols.pas new file mode 100644 index 0000000..bf523b9 --- /dev/null +++ b/src/tests/test_symbols.pas @@ -0,0 +1,131 @@ +unit test_symbols; + +// ============================================================================= +// Test file for LSP DocumentSymbol breadcrumb functionality +// +// This file is used to test the breadcrumb (symbol navigation bar) feature +// in LSP client IDEs such as VS Code, when using the Pascal Language Server. +// +// Test scenarios: +// 1. Class method breadcrumb: cursor in method body should show ClassName > MethodName +// 2. Nested functions: should appear in Outline view under their parent function +// 3. Class names: should not have trailing '=' character +// 4. Global functions: should appear at root level in Outline +// ============================================================================= + +{$mode objfpc}{$H+} + +interface + +type + { TTestClassA - Test class A } + TTestClassA = class + private + FValue: Integer; + public + procedure MethodA1; + procedure MethodA2; + function MethodA3: Integer; + end; + + { TTestClassB - Test class B } + TTestClassB = class + private + FName: String; + public + procedure MethodB1; + procedure MethodB2; + end; + + { TTestRecord - Test record type } + TTestRecord = record + X, Y: Integer; + end; + +procedure GlobalFunction1; +function GlobalFunction2(Value: Integer): Integer; + +implementation + +{ TTestClassA } + +procedure TTestClassA.MethodA1; +var + LocalVar: Integer; + + // Nested procedure 1 + procedure NestedProc1; + begin + LocalVar := 1; + end; + + // Nested function 2 + function NestedFunc2: Integer; + + // Deeply nested procedure + procedure DeeplyNested; + begin + LocalVar := 3; + end; + + begin + DeeplyNested; + Result := LocalVar; + end; + +begin + // Test point 1: cursor here should show breadcrumb: TTestClassA > MethodA1 + NestedProc1; + LocalVar := NestedFunc2; +end; + +procedure TTestClassA.MethodA2; +begin + // Test point 2: cursor here should show breadcrumb: TTestClassA > MethodA2 + FValue := 100; +end; + +function TTestClassA.MethodA3: Integer; +begin + // Test point 3: cursor here should show breadcrumb: TTestClassA > MethodA3 + Result := FValue; +end; + +{ TTestClassB } + +procedure TTestClassB.MethodB1; +begin + // Test point 4: cursor here should show breadcrumb: TTestClassB > MethodB1 + FName := 'Test'; +end; + +procedure TTestClassB.MethodB2; +begin + // Test point 5: cursor here should show breadcrumb: TTestClassB > MethodB2 + FName := FName + '!'; +end; + +{ Global Functions } + +procedure GlobalFunction1; +var + I: Integer; + + // Nested function inside global function + procedure NestedInGlobal; + begin + I := 42; + end; + +begin + // Test point 6: cursor here should show breadcrumb: GlobalFunction1 + NestedInGlobal; +end; + +function GlobalFunction2(Value: Integer): Integer; +begin + // Test point 7: cursor here should show breadcrumb: GlobalFunction2 + Result := Value * 2; +end; + +end. diff --git a/src/tests/testlsp.lpi b/src/tests/testlsp.lpi index f669640..d3b79a1 100644 --- a/src/tests/testlsp.lpi +++ b/src/tests/testlsp.lpi @@ -38,6 +38,10 @@ + + + + diff --git a/src/tests/testlsp.lpr b/src/tests/testlsp.lpr index 7d2d157..88be367 100644 --- a/src/tests/testlsp.lpr +++ b/src/tests/testlsp.lpr @@ -3,7 +3,8 @@ {$mode objfpc}{$H+} uses - Classes, consoletestrunner, Tests.Basic; + Classes, consoletestrunner, Tests.Basic, Tests.ClientProfile, Tests.DocumentSymbol, + Tests.SublimeProfile; type