diff --git a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs index 0f960020e..e3743e5f4 100644 --- a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs +++ b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs @@ -167,6 +167,70 @@ module CallHierarchyHelpers = open CallHierarchyHelpers +module TypeHierarchyHelpers = + + /// Get the SymbolKind for a type entity + let getEntitySymbolKind (entity: FSharpEntity) = + if entity.IsInterface then SymbolKind.Interface + elif entity.IsFSharpUnion then SymbolKind.Enum + elif entity.IsFSharpRecord then SymbolKind.Struct + elif entity.IsEnum then SymbolKind.Enum + elif entity.IsValueType then SymbolKind.Struct + elif entity.IsFSharpModule then SymbolKind.Module + else SymbolKind.Class + + /// Convert an FSharpEntity to a TypeHierarchyItem. + /// Returns None if the entity has no declaration location or is from an external assembly + /// (i.e., the source file does not exist on disk). This intentionally limits the type + /// hierarchy to user-defined source types, avoiding BCL/framework types that FCS may + /// implicitly add to DeclaredInterfaces. + let entityToTypeHierarchyItem (entity: FSharpEntity) : TypeHierarchyItem option = + try + let declLoc = entity.DeclarationLocation + + if not (System.IO.File.Exists declLoc.FileName) then + None + else + let uri = Path.LocalPathToUri(Utils.normalizePath declLoc.FileName) + let lspRange = fcsRangeToLsp declLoc + + Some + { TypeHierarchyItem.Name = entity.DisplayName + Kind = getEntitySymbolKind entity + Tags = None + Detail = entity.TryFullName + Uri = uri + Range = lspRange + SelectionRange = lspRange + Data = None } + with _ -> + None + + /// Get the direct supertypes (base class + declared interfaces) of an entity as TypeHierarchyItems + let getDirectSupertypes (entity: FSharpEntity) : TypeHierarchyItem[] = + [| match entity.BaseType with + | Some bt -> + try + if bt.TypeDefinition.TryFullName <> Some "System.Object" then + match entityToTypeHierarchyItem bt.TypeDefinition with + | Some item -> yield item + | None -> () + with _ -> + () + | None -> () + + for iface in entity.DeclaredInterfaces do + try + // Filter out System.Object which some FCS/CLR versions include for all interfaces + if iface.TypeDefinition.TryFullName <> Some "System.Object" then + match entityToTypeHierarchyItem iface.TypeDefinition with + | Some item -> yield item + | None -> () + with _ -> + () |] + +open TypeHierarchyHelpers + type AdaptiveFSharpLspServer ( workspaceLoader: IWorkspaceLoader, @@ -2561,11 +2625,203 @@ type AdaptiveFSharpLspServer return! returnException e logCfg } - override x.TextDocumentPrepareTypeHierarchy p = x.logUnimplementedRequest p + override x.TextDocumentPrepareTypeHierarchy(p: TypeHierarchyPrepareParams) = + asyncResult { + let tags = [ "TypeHierarchyPrepareParams", box p ] + use trace = fsacActivitySource.StartActivityForType(thisType, tags = tags) + + try + logger.info ( + Log.setMessage "TextDocumentPrepareTypeHierarchy Request: {params}" + >> Log.addContextDestructured "params" p + ) + + let (filePath, pos) = + { new ITextDocumentPositionParams with + member __.TextDocument = p.TextDocument + member __.Position = p.Position } + |> getFilePathAndPosition + + let! volatileFile = state.GetOpenFileOrRead filePath |> AsyncResult.ofStringErr + let! lineStr = tryGetLineStr pos volatileFile.Source |> Result.lineLookupErr + and! tyRes = state.GetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr + + let entity = + match tyRes.TryGetSymbolUse pos lineStr with + | None -> None + | Some su -> + match su.Symbol with + | :? FSharpEntity as e -> Some e + | :? FSharpMemberOrFunctionOrValue as mfv when mfv.IsConstructor -> mfv.DeclaringEntity + | _ -> None + + match entity with + | None -> return None + | Some entity -> + match entityToTypeHierarchyItem entity with + | None -> return None + | Some item -> return Some [| item |] + with e -> + trace |> Tracing.recordException e + + let logCfg = + Log.setMessage "TextDocumentPrepareTypeHierarchy Request Errored {p}" + >> Log.addContextDestructured "p" p + + return! returnException e logCfg + } + + override x.TypeHierarchySupertypes(p: TypeHierarchySupertypesParams) = + asyncResult { + let tags = [ "TypeHierarchySupertypesParams", box p ] + use trace = fsacActivitySource.StartActivityForType(thisType, tags = tags) - override x.TypeHierarchySubtypes p = x.logUnimplementedRequest p + try + logger.info ( + Log.setMessage "TypeHierarchySupertypes Request: {params}" + >> Log.addContextDestructured "params" p + ) - override x.TypeHierarchySupertypes p = x.logUnimplementedRequest p + let filePath = Path.FileUriToLocalPath p.Item.Uri |> Utils.normalizePath + let pos = protocolPosToPos p.Item.SelectionRange.Start + let! volatileFile = state.GetOpenFileOrRead filePath |> AsyncResult.ofStringErr + let! lineStr = tryGetLineStr pos volatileFile.Source |> Result.lineLookupErr + and! tyRes = state.GetTypeCheckResultsForFile filePath |> AsyncResult.ofStringErr + + let entity = + match tyRes.TryGetSymbolUse pos lineStr with + | None -> None + | Some su -> + match su.Symbol with + | :? FSharpEntity as e -> Some e + | :? FSharpMemberOrFunctionOrValue as mfv when mfv.IsConstructor -> mfv.DeclaringEntity + | _ -> None + + match entity with + | None -> return None + | Some entity -> + let supertypes = getDirectSupertypes entity + return if supertypes.Length = 0 then None else Some supertypes + with e -> + trace |> Tracing.recordException e + + let logCfg = + Log.setMessage "TypeHierarchySupertypes Request Errored {p}" + >> Log.addContextDestructured "p" p + + return! returnException e logCfg + } + + override x.TypeHierarchySubtypes(p: TypeHierarchySubtypesParams) = + asyncResult { + let tags = [ "TypeHierarchySubtypesParams", box p ] + use trace = fsacActivitySource.StartActivityForType(thisType, tags = tags) + + try + logger.info ( + Log.setMessage "TypeHierarchySubtypes Request: {params}" + >> Log.addContextDestructured "params" p + ) + + let filePath = Path.FileUriToLocalPath p.Item.Uri |> Utils.normalizePath + let pos = protocolPosToPos p.Item.SelectionRange.Start + let! volatileFile = state.GetOpenFileOrRead filePath |> AsyncResult.ofStringErr + let! lineStr = tryGetLineStr pos volatileFile.Source |> Result.lineLookupErr + and! tyRes = state.GetTypeCheckResultsForFile filePath |> AsyncResult.ofStringErr + + let targetEntity = + match tyRes.TryGetSymbolUse pos lineStr with + | None -> None + | Some su -> + match su.Symbol with + | :? FSharpEntity as e -> Some e + | :? FSharpMemberOrFunctionOrValue as mfv when mfv.IsConstructor -> mfv.DeclaringEntity + | _ -> None + + match targetEntity with + | None -> return None + | Some targetEntity -> + let getAllProjects () = + state.GetFilesToProject() + |> Async.map ( + Array.map (fun (file, proj) -> UMX.untag file, AVal.force proj.FSharpProjectCompilerOptions) + >> Array.toList + ) + + let! projs = getAllProjects () + let! allUses = state.GetUsesOfSymbol(filePath, projs, targetEntity) + + // For each unique file that references targetEntity, find entities that + // directly inherit from targetEntity via BaseType or DeclaredInterfaces. + // This is more reliable than range-containment on symbol use ranges, + // because u.Range in GetAllUsesOfAllSymbolsInFile is the identifier range + // (e.g. just "Dog"), not the full class body range. + let fileNames = allUses |> Array.map (fun su -> su.FileName) |> Array.distinct + + let! subtypeItemArrays = + fileNames + |> Array.map (fun fileName -> + async { + try + let useFilePath = Utils.normalizePath fileName + let! tyResResult = state.GetTypeCheckResultsForFile useFilePath + + match tyResResult with + | Error _ -> return [||] + | Ok useTyRes -> + let allFileUses = useTyRes.GetCheckResults.GetAllUsesOfAllSymbolsInFile() + + return + allFileUses + |> Seq.choose (fun u -> + if u.IsFromDefinition then + match u.Symbol with + | :? FSharpEntity as e when not (e.IsEffectivelySameAs targetEntity) -> + let isDirectSubtype = + try + (e.BaseType + |> Option.exists (fun bt -> + try + bt.TypeDefinition.IsEffectivelySameAs targetEntity + with _ -> + false)) + || (e.DeclaredInterfaces + |> Seq.exists (fun iface -> + try + iface.TypeDefinition.IsEffectivelySameAs targetEntity + with _ -> + false)) + with _ -> + false + + if isDirectSubtype then + entityToTypeHierarchyItem e + else + None + | _ -> None + else + None) + |> Seq.toArray + with _ -> + return [||] + }) + |> Async.parallel75 + + let subtypeItems = + subtypeItemArrays + |> Array.concat + |> Array.distinctBy (fun i -> i.Uri + string i.Range.Start.Line) + + return if subtypeItems.Length = 0 then None else Some subtypeItems + with e -> + trace |> Tracing.recordException e + + let logCfg = + Log.setMessage "TypeHierarchySubtypes Request Errored {p}" + >> Log.addContextDestructured "p" p + + return! returnException e logCfg + } override x.TextDocumentDeclaration p = x.logUnimplementedRequest p diff --git a/src/FsAutoComplete/LspServers/Common.fs b/src/FsAutoComplete/LspServers/Common.fs index 84cccb260..c46f8e9a5 100644 --- a/src/FsAutoComplete/LspServers/Common.fs +++ b/src/FsAutoComplete/LspServers/Common.fs @@ -280,6 +280,7 @@ module Helpers = FoldingRangeProvider = Some(U3.C1 true) SelectionRangeProvider = Some(U3.C1 true) CallHierarchyProvider = Some(U3.C1 true) + TypeHierarchyProvider = Some(U3.C1 true) SemanticTokensProvider = Some <| U2.C1 diff --git a/test/FsAutoComplete.Tests.Lsp/Program.fs b/test/FsAutoComplete.Tests.Lsp/Program.fs index af3f294d5..668ee5418 100644 --- a/test/FsAutoComplete.Tests.Lsp/Program.fs +++ b/test/FsAutoComplete.Tests.Lsp/Program.fs @@ -14,6 +14,7 @@ open FsAutoComplete.Tests.InteractiveDirectivesTests open FsAutoComplete.Tests.Lsp.CoreUtilsTests open FsAutoComplete.Tests.Lsp.DecompilerTests open FsAutoComplete.Tests.CallHierarchy +open FsAutoComplete.Tests.TypeHierarchy open Ionide.ProjInfo open System.Threading open Serilog.Filters @@ -138,6 +139,7 @@ let lspTests = UnusedDeclarationsTests.tests createServer EmptyFileTests.tests createServer CallHierarchy.tests createServer + TypeHierarchy.tests createServer diagnosticsTest createServer InheritDocTooltipTests.tests createServer diff --git a/test/FsAutoComplete.Tests.Lsp/TestCases/TypeHierarchy/Example1.fsx b/test/FsAutoComplete.Tests.Lsp/TestCases/TypeHierarchy/Example1.fsx new file mode 100644 index 000000000..0aa0825cc --- /dev/null +++ b/test/FsAutoComplete.Tests.Lsp/TestCases/TypeHierarchy/Example1.fsx @@ -0,0 +1,17 @@ +module TypeHierarchyExample + +type IAnimal = + abstract Sound: unit -> string + +type Animal(name: string) = + interface IAnimal with + member _.Sound() = "..." + member _.Name = name + +type Dog(name: string) = + inherit Animal(name) + override this.ToString() = sprintf "Dog: %s" this.Name + +type Cat(name: string) = + inherit Animal(name) + override this.ToString() = sprintf "Cat: %s" this.Name diff --git a/test/FsAutoComplete.Tests.Lsp/TypeHierarchyTests.fs b/test/FsAutoComplete.Tests.Lsp/TypeHierarchyTests.fs new file mode 100644 index 000000000..f9867e211 --- /dev/null +++ b/test/FsAutoComplete.Tests.Lsp/TypeHierarchyTests.fs @@ -0,0 +1,180 @@ +module FsAutoComplete.Tests.TypeHierarchy + +open Expecto +open System.IO +open FsAutoComplete +open Utils.ServerTests +open Helpers +open Utils.Server +open Ionide.LanguageServerProtocol.Types + +let examples = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "TypeHierarchy") + +let resultGet = + function + | Ok x -> x + | Error e -> failwithf "%A" e + +let resultOptionGet = + function + | Ok(Some x) -> x + | Ok(None) -> failwithf "Expected Some, got None" + | Error e -> failwithf "%A" e + +module TypeHierarchyPrepareParams = + let create (uri: DocumentUri) line character : TypeHierarchyPrepareParams = + { TextDocument = { Uri = uri } + Position = + { Line = uint32 line + Character = uint32 character } + WorkDoneToken = None } + +let tests createServer = + serverTestList "TypeHierarchy" createServer defaultConfigDto (Some examples) (fun server -> + [ testCaseAsync "PrepareTypeHierarchy returns item for class type" + <| async { + // Example1.fsx: + // Line 0: module TypeHierarchyExample + // Line 5: type Animal(name: string) = <- char 5 = 'A' + let! (doc, _) = Server.openDocument "Example1.fsx" server + use doc = doc + let! server = server + + let prepareParams = TypeHierarchyPrepareParams.create doc.Uri 5 5 + + let! result = + server.Server.TextDocumentPrepareTypeHierarchy prepareParams + |> Async.map resultOptionGet + + Expect.equal result.Length 1 "Should return exactly one TypeHierarchyItem" + Expect.equal result[0].Name "Animal" "Name should be Animal" + Expect.equal result[0].Kind SymbolKind.Class "Kind should be Class" + } + + testCaseAsync "PrepareTypeHierarchy returns item for interface type" + <| async { + // Example1.fsx: + // Line 2: type IAnimal = <- char 5 = 'I' + let! (doc, _) = Server.openDocument "Example1.fsx" server + use doc = doc + let! server = server + + let prepareParams = TypeHierarchyPrepareParams.create doc.Uri 2 5 + + let! result = + server.Server.TextDocumentPrepareTypeHierarchy prepareParams + |> Async.map resultOptionGet + + Expect.equal result.Length 1 "Should return exactly one TypeHierarchyItem" + Expect.equal result[0].Name "IAnimal" "Name should be IAnimal" + Expect.equal result[0].Kind SymbolKind.Interface "Kind should be Interface" + } + + testCaseAsync "PrepareTypeHierarchy returns None for non-type symbol" + <| async { + // Example1.fsx: + // Line 8: " member _.Name = name" <- char 11 = 'N' in "Name" + // "Name" is a member/property, not a type + let! (doc, _) = Server.openDocument "Example1.fsx" server + use doc = doc + let! server = server + + let prepareParams = TypeHierarchyPrepareParams.create doc.Uri 8 11 + + let! result = + server.Server.TextDocumentPrepareTypeHierarchy prepareParams + |> Async.map resultGet + + // A member symbol should not produce a type hierarchy item + match result with + | None -> () // expected: non-type symbol returns None + | Some items -> + // Accept if items is empty, or if the single item is not a type name + if items.Length > 0 then + Expect.notEqual items[0].Name "Animal" "Should not identify member as type" + } + + testCaseAsync "TypeHierarchySupertypes returns declared interfaces" + <| async { + // Animal implements IAnimal, so IAnimal should appear in supertypes + let! (doc, _) = Server.openDocument "Example1.fsx" server + use doc = doc + let! server = server + + let prepareParams = TypeHierarchyPrepareParams.create doc.Uri 5 5 + + let! prepareResult = + server.Server.TextDocumentPrepareTypeHierarchy prepareParams + |> Async.map resultOptionGet + + Expect.equal prepareResult.Length 1 "PrepareTypeHierarchy should succeed" + + let supertypesParams: TypeHierarchySupertypesParams = + { Item = prepareResult[0] + WorkDoneToken = None + PartialResultToken = None } + + let! supertypes = + server.Server.TypeHierarchySupertypes supertypesParams + |> Async.map resultOptionGet + + let supertypeNames = supertypes |> Array.map (fun i -> i.Name) + Expect.contains supertypeNames "IAnimal" "IAnimal should be listed as a supertype of Animal" + } + + testCaseAsync "TypeHierarchySupertypes returns None for type with no non-Object supertypes" + <| async { + // IAnimal is an interface with no base class, so no supertypes + let! (doc, _) = Server.openDocument "Example1.fsx" server + use doc = doc + let! server = server + + let prepareParams = TypeHierarchyPrepareParams.create doc.Uri 2 5 + + let! prepareResult = + server.Server.TextDocumentPrepareTypeHierarchy prepareParams + |> Async.map resultOptionGet + + Expect.equal prepareResult.Length 1 "PrepareTypeHierarchy should succeed" + + let supertypesParams: TypeHierarchySupertypesParams = + { Item = prepareResult[0] + WorkDoneToken = None + PartialResultToken = None } + + let! result = server.Server.TypeHierarchySupertypes supertypesParams |> Async.map resultGet + + // IAnimal has no supertypes (F# interfaces don't inherit System.Object in the type hierarchy sense) + match result with + | None -> () // expected + | Some items -> Expect.equal items.Length 0 "Should have no supertypes" + } + + testCaseAsync "TypeHierarchySubtypes returns direct subclasses" + <| async { + // Animal is inherited by Dog and Cat + let! (doc, _) = Server.openDocument "Example1.fsx" server + use doc = doc + let! server = server + + let prepareParams = TypeHierarchyPrepareParams.create doc.Uri 5 5 + + let! prepareResult = + server.Server.TextDocumentPrepareTypeHierarchy prepareParams + |> Async.map resultOptionGet + + Expect.equal prepareResult.Length 1 "PrepareTypeHierarchy should succeed" + + let subtypesParams: TypeHierarchySubtypesParams = + { Item = prepareResult[0] + WorkDoneToken = None + PartialResultToken = None } + + let! subtypes = server.Server.TypeHierarchySubtypes subtypesParams |> Async.map resultOptionGet + + let subtypeNames = subtypes |> Array.map (fun i -> i.Name) + + Expect.isGreaterThan subtypeNames.Length 0 "Should find at least one subtype" + Expect.contains subtypeNames "Dog" "Dog should be a subtype of Animal" + Expect.contains subtypeNames "Cat" "Cat should be a subtype of Animal" + } ])