From 4af6b2be8bd7afe35cea4fbb55c5ef45d7e54203 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Tue, 6 Oct 2026 18:03:23 +0200 Subject: [PATCH 1/5] Stabilize active-pattern tooling and measured catalogue cache Co-authored-by: Copilot App <223556219+Copilot@users.noreply.github.com> --- src/Compiler/Checking/NameResolution.fsi | 2 + src/Compiler/Service/FSharpCheckerResults.fs | 65 ++-- .../Service/ServiceAssemblyContent.fs | 52 ++- .../Service/ServiceDeclarationLists.fs | 5 +- src/Compiler/Service/ServiceParsedInputOps.fs | 39 +- .../Service/ServiceParsedInputOps.fsi | 9 + .../ActivePatternCompletionTests.fs | 332 ++++++++++++++++++ .../AssemblyContentProviderTests.fs | 146 +++++++- .../FSharp.Compiler.Service.Tests.fsproj | 1 + .../CodeFixes/AddOpenCodeFixProvider.fs | 96 ++++- .../AssemblyContentProvider.fs | 13 +- .../ActivePatternEditorTests.fs | 284 +++++++++++++++ .../AssemblyContentProviderTests.fs | 197 +++++++++++ .../FSharp.Editor.Tests.fsproj | 2 + 14 files changed, 1160 insertions(+), 83 deletions(-) create mode 100644 tests/FSharp.Compiler.Service.Tests/ActivePatternCompletionTests.fs create mode 100644 vsintegration/tests/FSharp.Editor.Tests/ActivePatternEditorTests.fs create mode 100644 vsintegration/tests/FSharp.Editor.Tests/AssemblyContentProviderTests.fs diff --git a/src/Compiler/Checking/NameResolution.fsi b/src/Compiler/Checking/NameResolution.fsi index fac10862948..7e5fe5478dc 100755 --- a/src/Compiler/Checking/NameResolution.fsi +++ b/src/Compiler/Checking/NameResolution.fsi @@ -1001,5 +1001,7 @@ val GetVisibleNamespacesAndModulesAtPoint: val IsItemResolvable: NameResolver -> NameResolutionEnv -> range -> AccessorDomain -> string list -> Item -> bool +val ItemIsUnseen: AccessorDomain -> TcGlobals -> ImportMap -> range -> allowObsolete: bool -> Item -> bool + val TrySelectExtensionMethInfoOfILExtMem: range -> ImportMap -> TType -> TyconRef * MethInfo * ExtensionMethodPriority -> MethInfo option diff --git a/src/Compiler/Service/FSharpCheckerResults.fs b/src/Compiler/Service/FSharpCheckerResults.fs index 4c5481e03e2..ef0e56b200d 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fs +++ b/src/Compiler/Service/FSharpCheckerResults.fs @@ -1564,10 +1564,15 @@ type internal TypeCheckInfo loc, filterCtors, resolveOverloads, - isInRangeOperator, + completionContext: CompletionContext option, allSymbols: unit -> AssemblySymbol list, options: FSharpCodeCompletionOptions ) = + let isInRangeOperator = + match completionContext with + | Some CompletionContext.RangeOperator -> true + | _ -> false + let isSpread = FindFirstNonWhitespacePosition lineStr (colAtEndOfNamesAndResidue - 1) |> Option.exists (fun i -> @@ -1761,6 +1766,19 @@ type internal TypeCheckInfo && match x.Symbol with + | :? FSharpActivePatternCase as symbol -> + match symbol.Item, completionContext with + | Item.ActivePatternCase case, Some(CompletionContext.Pattern _) -> + not ( + ItemIsUnseen + ad + g + ncenv.amap + m + options.SuggestObsoleteSymbols + (Item.Value case.ActivePatternVal) + ) + | _ -> false | :? FSharpMemberOrFunctionOrValue as m when m.IsConstructor && filterCtors = ResolveTypeNamesToTypeRefs -> @@ -1831,6 +1849,19 @@ type internal TypeCheckInfo | atStart when atStart = 0 -> 0 | otherwise -> otherwise - 1 + let pos = mkPos line colAtEndOfNamesAndResidue + + // Look for a "special" completion context + let completionContext = + // If the completion context we have computed higher up the stack is for the same position, + // reuse it, otherwise recompute + match completionContextAtPos with + | Some(contextForPos, context) when contextForPos = pos -> context + | _ -> + parseResultsOpt + |> Option.map (fun x -> x.ParseTree) + |> Option.bind (fun parseTree -> ParsedInput.TryGetCompletionContext(pos, parseTree, lineStr)) + let getDeclaredItemsNotInRangeOpWithAllSymbols () = GetDeclaredItems( parseResultsOpt, @@ -1843,24 +1874,11 @@ type internal TypeCheckInfo loc, filterCtors, resolveOverloads, - false, + completionContext, getAllSymbols, options ) - let pos = mkPos line colAtEndOfNamesAndResidue - - // Look for a "special" completion context - let completionContext = - // If the completion context we have computed higher up the stack is for the same position, - // reuse it, otherwise recompute - match completionContextAtPos with - | Some(contextForPos, context) when contextForPos = pos -> context - | _ -> - parseResultsOpt - |> Option.map (fun x -> x.ParseTree) - |> Option.bind (fun parseTree -> ParsedInput.TryGetCompletionContext(pos, parseTree, lineStr)) - let res = match completionContext with // Invalid completion locations @@ -1905,7 +1923,7 @@ type internal TypeCheckInfo loc, filterCtors, resolveOverloads, - false, + None, (fun () -> []), options ) @@ -1930,7 +1948,7 @@ type internal TypeCheckInfo loc, filterCtors, resolveOverloads, - false, + None, (fun () -> []), options ) @@ -1952,7 +1970,7 @@ type internal TypeCheckInfo loc, filterCtors, resolveOverloads, - false, + None, (fun () -> []), options ) @@ -2121,11 +2139,6 @@ type internal TypeCheckInfo // because providing generic parameters list is context aware, which we don't have here (yet). None | _ -> - let isInRangeOperator = - (match cc with - | Some CompletionContext.RangeOperator -> true - | _ -> false) - GetDeclaredItems( parseResultsOpt, lineStr, @@ -2137,7 +2150,7 @@ type internal TypeCheckInfo loc, filterCtors, resolveOverloads, - isInRangeOperator, + cc, getAllSymbols, options ) @@ -2229,7 +2242,9 @@ type internal TypeCheckInfo items let getAccessibility item = - FSharpSymbol.Create(cenv, item).Accessibility + match item with + | Item.ActivePatternCase case -> FSharpAccessibility(case.ActivePatternVal.Accessibility) + | _ -> FSharpSymbol.Create(cenv, item).Accessibility let currentNamespaceOrModule = parseResultsOpt diff --git a/src/Compiler/Service/ServiceAssemblyContent.fs b/src/Compiler/Service/ServiceAssemblyContent.fs index f08faa996a5..2fde460d218 100644 --- a/src/Compiler/Service/ServiceAssemblyContent.fs +++ b/src/Compiler/Service/ServiceAssemblyContent.fs @@ -12,6 +12,7 @@ open System.Collections.Generic open Internal.Utilities.Library open FSharp.Compiler.Diagnostics open FSharp.Compiler.IO +open FSharp.Compiler.NameResolution open FSharp.Compiler.Symbols open FSharp.Compiler.Syntax @@ -168,23 +169,33 @@ module AssemblyContent = UnresolvedSymbol = UnresolvedSymbol topRequireQualifiedAccessParent cleanIdents fullName ns }) - let traverseMemberFunctionAndValues ns (parent: Parent) (membersFunctionsAndValues: seq) = + let createFunctionOrValue ns (parent: Parent) = let topRequireQualifiedAccessParent = parent.TopRequiresQualifiedAccess false |> Option.map parent.FixParentModuleSuffix + let nearestRequireQualifiedAccessParent = parent.ThisRequiresQualifiedAccess true |> Option.map parent.FixParentModuleSuffix let autoOpenParent = parent.AutoOpen |> Option.map parent.FixParentModuleSuffix + fun fullName idents (symbol: FSharpSymbol) isActivePattern -> + let cleanedIdents = parent.FixParentModuleSuffix idents + { FullName = fullName + CleanedIdents = cleanedIdents + Namespace = ns + NearestRequireQualifiedAccessParent = nearestRequireQualifiedAccessParent + TopRequireQualifiedAccessParent = topRequireQualifiedAccessParent + AutoOpenParent = autoOpenParent + Symbol = symbol + Kind = fun _ -> EntityKind.FunctionOrValue isActivePattern + UnresolvedSymbol = UnresolvedSymbol topRequireQualifiedAccessParent cleanedIdents fullName ns } + + let isPublic (symbol: FSharpSymbol) = + match symbol.Item with + | Item.ActivePatternCase case -> case.ActivePatternVal.Accessibility.IsPublic + | _ -> symbol.Accessibility.IsPublic + + let traverseMemberFunctionAndValues (createSymbol: string -> ShortIdents -> FSharpSymbol -> bool -> AssemblySymbol) (membersFunctionsAndValues: seq) = membersFunctionsAndValues |> Seq.filter (fun x -> not x.IsInstanceMember && not x.IsPropertyGetterMethod && not x.IsPropertySetterMethod) |> Seq.collect (fun func -> let processIdents fullName idents = - let cleanedIdents = parent.FixParentModuleSuffix idents - { FullName = fullName - CleanedIdents = cleanedIdents - Namespace = ns - NearestRequireQualifiedAccessParent = parent.ThisRequiresQualifiedAccess true |> Option.map parent.FixParentModuleSuffix - TopRequireQualifiedAccessParent = topRequireQualifiedAccessParent - AutoOpenParent = autoOpenParent - Symbol = func - Kind = fun _ -> EntityKind.FunctionOrValue func.IsActivePattern - UnresolvedSymbol = UnresolvedSymbol topRequireQualifiedAccessParent cleanedIdents fullName ns } + createSymbol fullName idents func func.IsActivePattern [ yield! func.TryGetFullDisplayName() |> Option.map (fun fullDisplayName -> @@ -252,9 +263,23 @@ module AssemblyContent = Namespace = ns IsModule = entity.IsFSharpModule } + let createValue = createFunctionOrValue ns currentParent match entity.TryGetMembersFunctionsAndValues() with | xs when xs.Count > 0 -> - yield! traverseMemberFunctionAndValues ns currentParent xs + yield! traverseMemberFunctionAndValues createValue xs + | _ -> () + + match currentEntity with + | Some moduleSymbol when entity.IsFSharpModule -> + for case in entity.ActivePatternCases do + if contentType = Full || isPublic case then + let idents = Array.append moduleSymbol.CleanedIdents [| case.Name |] + let symbol = createValue case.FullName idents case true + let struct (_, openableNs, restIdents) = + Entity.getOpenableNamespace symbol.TopRequireQualifiedAccessParent symbol.AutoOpenParent symbol.CleanedIdents + yield { symbol with + UnresolvedSymbol = + UnresolvedSymbol None (Array.append openableNs restIdents) case.FullName (Some openableNs) } | _ -> () for e in (try entity.NestedEntities :> _ seq with _ -> Seq.empty) do @@ -312,7 +337,7 @@ module AssemblyContent = |> List.filter (fun entity -> match contentType with | Full -> true - | Public -> entity.Symbol.Accessibility.IsPublic) + | Public -> isPublic entity.Symbol) type EntityCache() = let dic = Dictionary() @@ -325,4 +350,3 @@ type EntityCache() = member _.Clear() = dic.Clear() member x.Locking f = lock dic <| fun _ -> f (x :> IAssemblyContentCache) - diff --git a/src/Compiler/Service/ServiceDeclarationLists.fs b/src/Compiler/Service/ServiceDeclarationLists.fs index 8d31b36f9c0..1deea463f86 100644 --- a/src/Compiler/Service/ServiceDeclarationLists.fs +++ b/src/Compiler/Service/ServiceDeclarationLists.fs @@ -1238,8 +1238,9 @@ type DeclarationListInfo(declarations: DeclarationListItem[], isForType: bool, i item.Unresolved |> Option.map (fun x -> x.Namespace) |> Option.bind (fun ns -> - if ns |> Array.startsWith fsharpNamespace then None - else Some ns) + match item.Item with + | Item.ActivePatternCase _ -> Some ns + | _ -> if ns |> Array.startsWith fsharpNamespace then None else Some ns) |> Option.map (fun ns -> match currentNamespace with | Some currentNs -> diff --git a/src/Compiler/Service/ServiceParsedInputOps.fs b/src/Compiler/Service/ServiceParsedInputOps.fs index 7ee76f4652e..bff04ef1658 100644 --- a/src/Compiler/Service/ServiceParsedInputOps.fs +++ b/src/Compiler/Service/ServiceParsedInputOps.fs @@ -204,6 +204,24 @@ module Entity = candidateNs[0 .. nsCount - 1] + let getOpenableNamespace (requiresQualifiedAccessParent: ShortIdents option) autoOpenParent (candidate: ShortIdents) = + let openableNsCount = + match requiresQualifiedAccessParent with + | Some parent -> min parent.Length candidate.Length + | None -> candidate.Length + + let fullOpenableNs = candidate[0 .. openableNsCount - 2] + struct (fullOpenableNs, cutAutoOpenModules autoOpenParent fullOpenableNs, candidate[openableNsCount - 1 ..]) + + let formatIdents idents = + idents + |> Array.map (fun ident -> + if IsOperatorDisplayName ident then + ident + else + NormalizeIdentifierBackticks ident) + |> String.concat "." + let tryCreate ( targetNamespace: ShortIdents option, @@ -230,15 +248,8 @@ module Entity = else let identCount = parts.Length - let fullOpenableNs, restIdents = - let openableNsCount = - match requiresQualifiedAccessParent with - | Some parent -> min parent.Length candidate.Length - | None -> candidate.Length - - candidate[0 .. openableNsCount - 2], candidate[openableNsCount - 1 ..] - - let openableNs = cutAutoOpenModules autoOpenParent fullOpenableNs + let struct (fullOpenableNs, openableNs, restIdents) = + getOpenableNamespace requiresQualifiedAccessParent autoOpenParent candidate let getRelativeNs ns = match targetNamespace, candidateNamespace with @@ -258,8 +269,8 @@ module Entity = match relativeNs with | [||] -> None | _ when identCount > 1 && relativeNs.Length >= identCount -> - Some(relativeNs[0 .. relativeNs.Length - identCount] |> String.concat ".") - | _ -> Some(relativeNs |> String.concat ".") + Some(relativeNs[0 .. relativeNs.Length - identCount] |> formatIdents) + | _ -> Some(formatIdents relativeNs) let qualifier = if fullRelativeName.Length > 1 && fullRelativeName.Length >= identCount then @@ -269,13 +280,13 @@ module Entity = Some { - FullRelativeName = String.concat "." fullRelativeName //.[0..fullRelativeName.Length - identCount - 1] - Qualifier = String.concat "." qualifier + FullRelativeName = formatIdents fullRelativeName + Qualifier = formatIdents qualifier Namespace = ns FullDisplayName = match restIdents with | [| _ |] -> "" - | _ -> String.concat "." restIdents + | _ -> formatIdents restIdents LastIdent = Array.tryLast restIdents |> Option.defaultValue "" }) diff --git a/src/Compiler/Service/ServiceParsedInputOps.fsi b/src/Compiler/Service/ServiceParsedInputOps.fsi index 1b28bfb18d3..a816b423b80 100644 --- a/src/Compiler/Service/ServiceParsedInputOps.fsi +++ b/src/Compiler/Service/ServiceParsedInputOps.fsi @@ -210,6 +210,15 @@ module public ParsedInput = /// Corrects insertion line number based on kind of scope and text surrounding the insertion point. val AdjustInsertionPoint: getLineStr: (int -> string) -> ctx: InsertionContext -> pos +[] +module internal Entity = + + val getOpenableNamespace: + requiresQualifiedAccessParent: ShortIdents option -> + autoOpenParent: ShortIdents option -> + candidate: ShortIdents -> + struct (ShortIdents * ShortIdents * ShortIdents) + // implementation details used by other code in the compiler module internal SourceFileImpl = diff --git a/tests/FSharp.Compiler.Service.Tests/ActivePatternCompletionTests.fs b/tests/FSharp.Compiler.Service.Tests/ActivePatternCompletionTests.fs new file mode 100644 index 00000000000..345d1f79220 --- /dev/null +++ b/tests/FSharp.Compiler.Service.Tests/ActivePatternCompletionTests.fs @@ -0,0 +1,332 @@ +module FSharp.Compiler.Service.Tests.ActivePatternCompletionTests + +open System +open FSharp.Compiler.CodeAnalysis +open FSharp.Compiler.EditorServices +open FSharp.Compiler.Service.Tests.Common +open FSharp.Compiler.Symbols +open FSharp.Compiler.Syntax.PrettyNaming +open FSharp.Compiler.Text +open Xunit + +let private patterns = """ +namespace Candidates +open System + +module Normal = + let ordinaryValue = 1 + let (++) left right = 10 * left + right + type Thing = class end + let (|Even|Odd|) value = if value % 2 = 0 then Even else Odd + let (|Total|) value = value + let (|Positive|_|) value = if value > 0 then Some value else None + let (|Above|_|) threshold value = if value > threshold then Some value else None + let private (|Private|_|) value = Some value + let internal (|Internal|_|) value = Some value + [] + let (|Old|_|) value = Some value + [] + let (|Hidden|_|) value = Some value + +module private PrivateModule = + let (|Secret|_|) value = Some value + +module Other = + let (|Positive|_|) value = Some value + +[] +module Auto = + let (|AutoCase|_|) value = Some value + [] + module Nested = + let (|Deep|_|) value = Some value + module Ordinary = + let (|OrdinaryCase|_|) value = Some value + +[] +module Qualified = + let (|Restricted|_|) value = Some value + +[] +module Suffix = + let (|SuffixCase|_|) value = Some value + +module ``Space module`` = + let (|``Has space``|_|) value = Some value + +namespace Microsoft.FSharp.Core +module Unopened = + let coreValue = 1 + let (|CoreCase|_|) value = Some value +""" + +let private check markedSource = + let context = Checker.getCompletionContext markedSource + let options = createProjectOptionsFromNamedSources [ "Patterns.fs", patterns; "Consumer.fs", context.Source ] [] + let _, producer = parseAndCheckFile options.SourceFiles[0] patterns options + Assert.Empty producer.Diagnostics + let parse, results = parseAndCheckFile options.SourceFiles[1] context.Source options + let catalogue = AssemblyContent.GetAssemblySignatureContent AssemblyContentType.Full results.PartialAssemblySignature + let complete completionOptions getAllEntities = + results.GetDeclarationListInfo( + Some parse, context.Pos.Line, context.LineText, context.PartialIdentifier, + getAllEntities = getAllEntities, options = completionOptions) + let item predicate = + (complete FSharpCodeCompletionOptions.Default (fun () -> catalogue)).Items + |> Array.filter predicate + |> Assert.Single + let insert (symbol: AssemblySymbol) partiallyQualified = + ParsedInput.TryFindInsertionContext context.Pos.Line parse.ParseTree partiallyQualified OpenStatementInsertionPoint.TopLevel + (symbol.TopRequireQualifiedAccessParent, symbol.AutoOpenParent, symbol.Namespace, symbol.CleanedIdents) + |> Assert.Single + struct {| Options = options; Context = context; Parse = parse; Results = results; Catalogue = catalogue; Complete = complete; Item = item; Insert = insert |} + +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +let ``unopened cases provide compiling completion and import edits`` (caseName: string, owner: string, arguments: string, nameInCode: string, namespaceToOpen: string, qualifiedName: string) = + let sourceName = NormalizeIdentifierBackticks caseName + let marked = $"module Consumer\nlet classify value = match value with | {sourceName}{{caret}}{arguments} -> 1 | _ -> 0" + let test = check marked + if arguments <> "" then + Assert.Contains(test.Results.Diagnostics, fun diagnostic -> diagnostic.ErrorNumber = 39) + let symbol = + test.Catalogue + |> List.find (fun symbol -> String.concat "." symbol.CleanedIdents = $"Candidates.{owner}.{caseName}") + let entity, insertionContext = + test.Insert symbol [| { Ident = caseName; Resolved = false } |] + Assert.Equal(Some namespaceToOpen, entity.Namespace) + Assert.Equal(qualifiedName, entity.FullRelativeName) + Assert.Equal(qualifiedName, entity.Qualifier) + let importedName = if entity.FullDisplayName = "" then sourceName else entity.FullDisplayName + Assert.Equal(nameInCode, importedName) + + let item = test.Item (fun item -> item.FullName = symbol.FullName) + Assert.Equal(nameInCode, item.NameInCode) + Assert.Equal(Some namespaceToOpen, item.NamespaceToOpen) + + let checkEdit insertedName openNamespace = + let source = test.Context.Source.Replace(sourceName, insertedName, StringComparison.Ordinal) + let lines = SourceContext.getLines source + let edited = + match openNamespace with + | Some ns -> + let pos = ParsedInput.AdjustInsertionPoint (fun line -> lines[line].Trim()) insertionContext + Assert.Equal(Position.mkPos 2 0, pos) + lines |> Array.insertAt (pos.Line - 1) $"open {ns}" |> String.concat "\n" + | None -> source + let _, results = parseAndCheckFile test.Options.SourceFiles[1] edited test.Options + Assert.Empty results.Diagnostics + if openNamespace.IsSome then + let unused = UnusedOpens.getUnusedOpens(results, fun line -> (SourceContext.getLines edited)[line - 1]) |> Async.RunSynchronouslyImmediate + Assert.Empty unused + checkEdit item.NameInCode item.NamespaceToOpen + checkEdit entity.Qualifier None + +[] +[ n")>] +[] +[ n")>] +let ``unopened cases complete match binding and lambda patterns`` (body: string) = + let test = check $"module Consumer\n{body}" + let symbol = test.Catalogue |> List.find (fun symbol -> symbol.CleanedIdents = [| "Candidates"; "Normal"; "Total" |]) + let item = test.Item (fun item -> item.FullName = symbol.FullName) + Assert.Equal("Total", item.NameInCode) + Assert.Equal(Some "Candidates.Normal", item.NamespaceToOpen) + let edited = $"""module Consumer +open {item.NamespaceToOpen.Value} +{body.Replace("{caret}", "", StringComparison.Ordinal)}""" + let _, results = parseAndCheckFile test.Options.SourceFiles[1] edited test.Options + Assert.Empty results.Diagnostics + +[] +[] +[] +let ``case completion uses backing value visibility and obsolete settings`` suggestObsolete = + let test = check "module Consumer\nlet classify value = match value with | P{caret} n -> 1 | _ -> 0" + let options = { FSharpCodeCompletionOptions.Default with SuggestObsoleteSymbols = suggestObsolete } + let items = (test.Complete options (fun () -> test.Catalogue)).Items + let contains name = items |> Array.exists (fun item -> item.FullName.EndsWith($".{name}", StringComparison.Ordinal)) + Assert.False(contains "Private") + Assert.False(contains "Secret") + if not suggestObsolete then Assert.False(contains "Hidden") + Assert.Equal(suggestObsolete, contains "Old") + Assert.True(contains "Internal") + let internalCase = items |> Array.find (fun item -> item.FullName.EndsWith(".Internal", StringComparison.Ordinal)) + Assert.True internalCase.Accessibility.IsInternal + +[] +let ``case catalogue does not leak into expressions`` () = + let test = check "module Consumer\nlet value = P{caret}" + let info = test.Complete FSharpCodeCompletionOptions.Default (fun () -> test.Catalogue) + let identities = + test.Catalogue + |> List.filter (fun symbol -> symbol.Symbol :? FSharpActivePatternCase) + |> List.map _.FullName + |> Set.ofList + Assert.DoesNotContain(info.Items, fun item -> identities.Contains item.FullName) + Assert.Contains(info.Items, fun item -> item.NameInCode = "Normal" && item.NamespaceToOpen = Some "Candidates") + let symbols = + test.Results.GetDeclarationListSymbols( + Some test.Parse, test.Context.Pos.Line, test.Context.LineText, test.Context.PartialIdentifier, + getAllEntities = (fun () -> test.Catalogue)) + |> List.collect id + Assert.DoesNotContain(symbols, fun symbol -> identities.Contains symbol.Symbol.FullName) + +[] +[ n | _ -> 0", true)>] +[ n | _ -> 0", true)>] +[ n | _ -> 0", true)>] +[ n | _ -> 0", true)>] +[] +let ``editor scoped case query reuses FCS context and backing value policies`` (body: string, isPattern: bool) = + let test = check $"module Consumer\n{body}" + let cases = test.Catalogue |> List.filter (fun symbol -> symbol.Symbol :? FSharpActivePatternCase) + let partialName = { test.Context.PartialIdentifier with QualifyingIdents = []; PartialIdent = ""; LastDotPos = None } + let identities = + test.Results.GetDeclarationListSymbols( + Some test.Parse, test.Context.Pos.Line, test.Context.LineText, partialName, getAllEntities = (fun () -> cases)) + |> List.collect id + |> List.map (fun symbol -> symbol.Symbol.FullName) + |> Set.ofList + for case in cases do + let name = Array.last case.CleanedIdents + if name = "Private" || name = "Secret" || name = "Hidden" || name = "Old" then + Assert.False(identities.Contains case.FullName) + elif name = "Positive" then + Assert.Equal(isPattern, identities.Contains case.FullName) + +[] +[] +[] +let ``editor RQA action keeps the qualification needed by the applied pattern`` (pattern: string, canOpen: bool) = + let test = check $"module Consumer\nlet classify value = match value with | {pattern}{{caret}} n -> n | _ -> 0" + let symbol = test.Catalogue |> List.find (fun symbol -> symbol.CleanedIdents = [| "Candidates"; "Qualified"; "Restricted" |]) + let unresolved = + pattern.Split '.' + |> Array.mapi (fun index ident -> { Ident = ident; Resolved = index <> 0 }) + let entity, _ = test.Insert symbol unresolved + Assert.Equal(canOpen, entity.FullDisplayName = "" || entity.FullDisplayName = pattern) + let edited = + if canOpen then + Assert.Equal(Some "Candidates", entity.Namespace) + test.Context.Source.Replace("module Consumer", "module Consumer\nopen Candidates", StringComparison.Ordinal) + else + Assert.Equal("Candidates.Qualified.Restricted", entity.Qualifier) + test.Context.Source.Replace("| Restricted n", $"| {entity.Qualifier} n", StringComparison.Ordinal) + let _, results = parseAndCheckFile test.Options.SourceFiles[1] edited test.Options + Assert.Empty results.Diagnostics + +[] +let ``case completion preserves per call catalogues and distinct candidates`` () = + let test = check "module Consumer\nlet classify value = match value with | Positive{caret} n -> 1 | _ -> 0" + let complete catalogue = (test.Complete FSharpCodeCompletionOptions.Default (fun () -> catalogue)).Items + let cases = test.Catalogue |> List.filter (fun symbol -> symbol.Symbol :? FSharpActivePatternCase) + let candidates = complete cases |> Array.filter (fun item -> item.NameInCode = "Positive") + Assert.Equal([| Some "Candidates.Normal"; Some "Candidates.Other" |], candidates |> Array.map _.NamespaceToOpen |> Array.sort) + Assert.DoesNotContain(complete [], fun item -> candidates |> Array.exists (fun candidate -> candidate.FullName = item.FullName)) + for candidate in candidates do + let catalogue = cases |> List.filter (fun symbol -> symbol.FullName = candidate.FullName) + let actual = complete catalogue |> Array.filter (fun item -> item.NameInCode = "Positive") |> Assert.Single + Assert.Equal(candidate.NamespaceToOpen, actual.NamespaceToOpen) + +[] +[] +[] +[] +let ``already visible cases are not duplicated by the catalogue`` (openNamespace: string, caseName: string) = + let test = check $"module Consumer\nopen {openNamespace}\nlet classify value = match value with | {caseName}{{caret}} n -> 1 | _ -> 0" + let candidates = + (test.Complete FSharpCodeCompletionOptions.Default (fun () -> test.Catalogue)).Items + |> Array.filter (fun item -> item.NameInCode = caseName) + let expected = if caseName = "Positive" then [| None; Some "Candidates.Other" |] else [| None |] + Assert.Equal(expected, candidates |> Array.map _.NamespaceToOpen |> Array.sort) + +[] +let ``private cases remain available inside their defining module`` () = + let test = check """ +module Consumer +module Local = + let private (|LocalPrivate|_|) value = Some value + let classify value = match value with | LocalPrivate{caret} n -> n | _ -> 0 +""" + let symbol = test.Catalogue |> List.find (fun symbol -> symbol.CleanedIdents = [| "Consumer"; "Local"; "LocalPrivate" |]) + let item = test.Item (fun item -> item.FullName = symbol.FullName) + Assert.Equal("LocalPrivate", item.NameInCode) + Assert.Equal(None, item.NamespaceToOpen) + +[] +let ``partially qualified case uses existing import and qualification paths`` () = + let test = check "module Consumer\nlet classify value = match value with | Normal.Positive{caret} n -> 1 | _ -> 0" + let symbol = test.Catalogue |> List.find (fun symbol -> symbol.CleanedIdents = [| "Candidates"; "Normal"; "Positive" |]) + let entity, _ = + test.Insert symbol [| { Ident = "Normal"; Resolved = false }; { Ident = "Positive"; Resolved = true } |] + Assert.Equal(Some "Candidates", entity.Namespace) + Assert.Equal("Candidates.Normal", entity.Qualifier) + let edited = test.Context.Source.Replace("Normal.Positive", $"{entity.Qualifier}.Positive", StringComparison.Ordinal) + let _, results = parseAndCheckFile test.Options.SourceFiles[1] edited test.Options + Assert.Empty results.Diagnostics + let opened = test.Context.Source.Replace("module Consumer", "module Consumer\nopen Candidates", StringComparison.Ordinal) + let _, results = parseAndCheckFile test.Options.SourceFiles[1] opened test.Options + Assert.Empty results.Diagnostics + let visible = check (opened.Replace("Normal.Positive", "Normal.Positive{caret}", StringComparison.Ordinal)) + let item = visible.Item (fun item -> item.NameInCode = "Positive") + Assert.Equal(None, item.NamespaceToOpen) + +[] +let ``unknown bare uppercase binding remains valid`` () = + let test = check "module Consumer\nlet Even{caret} = 1" + Assert.Empty test.Results.Diagnostics + test.Complete FSharpCodeCompletionOptions.Default (fun () -> test.Catalogue) |> ignore + Assert.Empty test.Results.Diagnostics + +[] +let ``FSharp namespace does not make an unopened case module visible`` () = + let test = check "module Consumer\nlet classify value = match value with | CoreCase{caret} n -> n | _ -> 0" + let item = test.Item (fun item -> item.NameInCode = "CoreCase") + Assert.Equal(Some "Microsoft.FSharp.Core.Unopened", item.NamespaceToOpen) + let edited = test.Context.Source.Replace("module Consumer", $"module Consumer\nopen {item.NamespaceToOpen.Value}", StringComparison.Ordinal) + let _, results = parseAndCheckFile test.Options.SourceFiles[1] edited test.Options + Assert.Empty results.Diagnostics + +[] +let ``FSharp namespace keeps ordinary value completion without an extra open`` () = + let test = check "module Consumer\nopen Microsoft.FSharp.Core\nlet value = coreValue{caret}" + let symbol = test.Catalogue |> List.find (fun symbol -> symbol.CleanedIdents = [| "Microsoft"; "FSharp"; "Core"; "Unopened"; "coreValue" |]) + let item = + (test.Complete FSharpCodeCompletionOptions.Default (fun () -> test.Catalogue)).Items + |> Array.filter (fun item -> item.FullName = symbol.FullName) + |> Assert.Single + Assert.Equal("Unopened.coreValue", item.NameInCode) + Assert.Equal(None, item.NamespaceToOpen) + let edited = test.Context.Source.Replace("coreValue", item.NameInCode, StringComparison.Ordinal) + let _, results = parseAndCheckFile test.Options.SourceFiles[1] edited test.Options + Assert.Empty results.Diagnostics + +[] +[] +[] +[] +let ``existing value type and operator import paths still compile`` (name: string, body: string) = + let test = check $"module Consumer\n{body}" + let symbol = test.Catalogue |> List.find (fun symbol -> symbol.CleanedIdents = [| "Candidates"; "Normal"; name |]) + let entity, _ = + test.Insert symbol [| { Ident = name; Resolved = false } |] + Assert.Equal(Some "Candidates.Normal", entity.Namespace) + Assert.Equal($"Candidates.Normal.{name}", entity.Qualifier) + for edited in + [ test.Context.Source.Replace(name, entity.Qualifier, StringComparison.Ordinal) + test.Context.Source.Replace("module Consumer", "module Consumer\nopen Candidates.Normal", StringComparison.Ordinal) ] do + let _, results = parseAndCheckFile test.Options.SourceFiles[1] edited test.Options + Assert.Empty results.Diagnostics + if name <> "(++)" then + let item = test.Item (fun item -> item.FullName = symbol.FullName) + Assert.Equal($"Normal.{name}", item.NameInCode) + Assert.Equal(Some "Candidates", item.NamespaceToOpen) diff --git a/tests/FSharp.Compiler.Service.Tests/AssemblyContentProviderTests.fs b/tests/FSharp.Compiler.Service.Tests/AssemblyContentProviderTests.fs index 5df4bf71912..2b2afc68166 100644 --- a/tests/FSharp.Compiler.Service.Tests/AssemblyContentProviderTests.fs +++ b/tests/FSharp.Compiler.Service.Tests/AssemblyContentProviderTests.fs @@ -1,19 +1,22 @@ module FSharp.Compiler.Service.Tests.AssemblyContentProviderTests open System +open System.IO open FSharp.Compiler.CodeAnalysis open FSharp.Compiler.EditorServices open FSharp.Compiler.Service.Tests.Common +open FSharp.Compiler.Symbols open FSharp.Test +open Xunit -let private filePath = "C:\\test.fs" +let private filePath = Path.Combine(Path.GetTempPath(), "test.fs") let private projectOptions : FSharpProjectOptions = - { ProjectFileName = "C:\\test.fsproj" + { ProjectFileName = Path.ChangeExtension(filePath, ".fsproj") ProjectId = None SourceFiles = [| filePath |] ReferencedProjects = [| |] - OtherOptions = [| |] + OtherOptions = mkProjectCommandLineArgsSilent ("test.dll", []) IsIncompleteTypeCheckEnvironment = true UseScriptResolutionRules = false LoadTime = DateTime.MaxValue @@ -62,7 +65,7 @@ let private getSymbolMap (getSymbolProperty: AssemblySymbol -> 'a) (source: stri |> List.map (fun s -> getCleanedFullName s, getSymbolProperty s) |> Map.ofList -[] +[] let ``implicitly added Module suffix is removed``() = """ type MyType = { F: int } @@ -75,7 +78,7 @@ module MyType = "Test.MyType" "Test.MyType.func123"] -[] +[] let ``Module suffix added by an explicitly applied ModuleSuffix attribute is removed``() = """ [] @@ -86,7 +89,7 @@ module MyType = "Test.MyType" "Test.MyType.func123" ] -[] +[] let ``Property getters and setters are removed``() = """ type MyType() = @@ -96,7 +99,7 @@ let ``Property getters and setters are removed``() = "Test.MyType" "Test.MyType.MyProperty" ] -[] +[] let ``TopRequireQualifiedAccessParent property should be valid``() = let source = """ module M1 = @@ -143,7 +146,7 @@ let ``TopRequireQualifiedAccessParent property should be valid``() = assertAreEqual (expectedResult, actual) -[] +[] let ``Check Unresolved Symbols``() = let source = """ namespace ``1 2 3`` @@ -206,6 +209,7 @@ module Test = "1 2 3.Test.M1.E", "open ``1 2 3`` - Test.M1.E"; "1 2 3.Test.M1.F", "open ``1 2 3`` - Test.M1.F"; "1 2 3.Test.M1.G", "open ``1 2 3`` - Test.M1.G"; + "1 2 3.Test.M1.Is1", "open ``1 2 3``.Test.M1 - Is1"; "1 2 3.Test.M1.M11", "open ``1 2 3`` - Test.M1.M11"; "1 2 3.Test.M1.M11.M111", "open ``1 2 3`` - Test.M1.M11.M111"; "1 2 3.Test.M1.M11.M111.v111", "open ``1 2 3`` - Test.M1.M11.M111.v111"; @@ -227,3 +231,129 @@ module Test = $"open {ns} - {i.UnresolvedSymbol.DisplayName}") assertAreEqual (expectedResult, actual) + +let private activePatternSource = """ +namespace Catalogue + +[] +[] +module Patterns = + let (|Even|Odd|) value = if value % 2 = 0 then Even else Odd + let (|Positive|_|) value = if value > 0 then Some value else None + let (|Above|_|) threshold value = if value > threshold then Some value else None + let (|Case|CASE|) value = if value then Case else CASE + let (|``Has space``|_|) value = if value > 0 then Some value else None + let private (|Private|_|) value = if value > 0 then Some value else None + let internal (|Internal|_|) value = if value > 0 then Some value else None + + [] + module Nested = + let (|Even|_|) value = if value % 2 = 0 then Some value else None + + module private Hidden = + let (|HiddenCase|_|) value = if value > 0 then Some value else None +""" + +let private checkSources sources = + let options = createProjectOptionsFromNamedSources sources [] + let filePath = Array.last options.SourceFiles + let _, results = parseAndCheckFile filePath (snd (List.last sources)) options + Assert.Empty results.Diagnostics + options, results + +let private activePatternCases symbols = + symbols + |> List.filter (fun symbol -> symbol.Symbol :? FSharpActivePatternCase) + +[] +[] +[] +[] +[] +[] +[] +[] +let ``active pattern catalogue preserves case identity and source names`` (caseName, index) = + let _, results = checkSources [ "Patterns.fs", activePatternSource ] + let symbols = AssemblyContent.GetAssemblySignatureContent AssemblyContentType.Full results.PartialAssemblySignature + let symbol = + activePatternCases symbols + |> List.find (fun symbol -> symbol.CleanedIdents = [| "Catalogue"; "Patterns"; caseName |]) + let case = Assert.IsType symbol.Symbol + Assert.Equal(caseName, case.Name) + Assert.Equal(index, case.Index) + Assert.Equal(case.FullName, symbol.FullName) + Assert.NotEqual(getCleanedFullName symbol, symbol.FullName) + Assert.Equal(Some [| "Catalogue" |], symbol.Namespace) + Assert.Equal(Some [| "Catalogue"; "Patterns" |], symbol.NearestRequireQualifiedAccessParent) + Assert.Equal(Some [| "Catalogue"; "Patterns" |], symbol.TopRequireQualifiedAccessParent) + Assert.Equal(None, symbol.AutoOpenParent) + Assert.Equal(symbol.FullName, symbol.UnresolvedSymbol.FullName) + Assert.Equal([| "Catalogue" |], symbol.UnresolvedSymbol.Namespace) + let sourceName = FSharp.Compiler.Syntax.PrettyNaming.NormalizeIdentifierBackticks caseName + Assert.Equal($"Patterns.{sourceName}", symbol.UnresolvedSymbol.DisplayName) + Assert.Equal(EntityKind.FunctionOrValue true, symbol.Kind LookupType.Precise) + Assert.Contains(symbols, fun symbol -> + match symbol.Symbol with + | :? FSharpMemberOrFunctionOrValue as value -> value.IsActivePattern && case.Group.Name = Some value.LogicalName + | _ -> false) + +[] +[] +[] +let ``active pattern catalogue respects defining value and container visibility`` publicOnly = + let project, results = checkSources [ "Patterns.fs", activePatternSource ] + let contentType = if publicOnly then AssemblyContentType.Public else AssemblyContentType.Full + let expected = + [ "Catalogue.Patterns.Above"; "Catalogue.Patterns.CASE"; "Catalogue.Patterns.Case" + "Catalogue.Patterns.Even"; "Catalogue.Patterns.Has space"; "Catalogue.Patterns.Nested.Even" + "Catalogue.Patterns.Odd"; "Catalogue.Patterns.Positive" + if not publicOnly then + "Catalogue.Patterns.Hidden.HiddenCase" + "Catalogue.Patterns.Internal" + "Catalogue.Patterns.Private" ] + |> List.sort + let output = Path.ChangeExtension(project.ProjectFileName, ".dll") + let source = """ +module Consumer +let classified = match 2 with | Catalogue.Patterns.Even -> true | Catalogue.Patterns.Odd -> false +""" + let options = createProjectOptionsFromNamedSources [ "Consumer.fs", source ] [ $"-r:{output}" ] + let options = { options with ReferencedProjects = [| FSharpReferencedProject.FSharpReference(output, project) |] } + let _, consumer = parseAndCheckFile options.SourceFiles[0] source options + Assert.Empty consumer.Diagnostics + let assemblies = + consumer.ProjectContext.GetReferencedAssemblies() + |> List.filter (fun assembly -> assembly.SimpleName = Path.GetFileNameWithoutExtension output) + Assert.Single assemblies |> ignore + let catalogue = AssemblyContent.GetAssemblySignatureContent contentType results.PartialAssemblySignature + let actual = activePatternCases catalogue |> List.map getCleanedFullName |> List.sort + Assert.Equal(expected, actual) + let nested = catalogue |> List.find (fun symbol -> getCleanedFullName symbol = "Catalogue.Patterns.Nested.Even") + Assert.Equal(Some [| "Catalogue"; "Patterns"; "Nested" |], nested.AutoOpenParent) + let cache = EntityCache() + let cacheKey = Some project.SourceFiles[0] + AssemblyContent.GetAssemblyContent cache.Locking AssemblyContentType.Full cacheKey assemblies |> ignore + let cached = + AssemblyContent.GetAssemblyContent cache.Locking contentType cacheKey assemblies + |> activePatternCases + |> List.map getCleanedFullName + |> List.sort + Assert.Equal(expected, cached) + +[] +let ``active pattern catalogue respects signature visibility`` () = + let signature = """ +namespace Catalogue +[] +[] +module Patterns = + val (|Even|Odd|): int -> Choice +""" + let _, results = checkSources [ "Patterns.fsi", signature; "Patterns.fs", activePatternSource ] + let actual = + AssemblyContent.GetAssemblySignatureContent AssemblyContentType.Full results.PartialAssemblySignature + |> activePatternCases + |> List.map getCleanedFullName + |> List.sort + Assert.Equal([ "Catalogue.Patterns.Even"; "Catalogue.Patterns.Odd" ], actual) diff --git a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj index 2ff9555dee6..b92e18f663c 100644 --- a/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj +++ b/tests/FSharp.Compiler.Service.Tests/FSharp.Compiler.Service.Tests.fsproj @@ -135,6 +135,7 @@ + diff --git a/vsintegration/src/FSharp.Editor/CodeFixes/AddOpenCodeFixProvider.fs b/vsintegration/src/FSharp.Editor/CodeFixes/AddOpenCodeFixProvider.fs index 57bca908da6..5871b0bdb97 100644 --- a/vsintegration/src/FSharp.Editor/CodeFixes/AddOpenCodeFixProvider.fs +++ b/vsintegration/src/FSharp.Editor/CodeFixes/AddOpenCodeFixProvider.fs @@ -3,6 +3,7 @@ namespace Microsoft.VisualStudio.FSharp.Editor open System +open System.Collections.Generic open System.Composition open System.Collections.Immutable @@ -10,6 +11,7 @@ open Microsoft.CodeAnalysis.Text open Microsoft.CodeAnalysis.CodeFixes open FSharp.Compiler.EditorServices +open FSharp.Compiler.Symbols open FSharp.Compiler.Syntax open FSharp.Compiler.Text @@ -158,26 +160,65 @@ type internal AddOpenCodeFixProvider [] (assemblyContentPr let isAttribute = ParsedInput.GetEntityKind(unresolvedIdentRange.Start, parseResults.ParseTree) = Some EntityKind.Attribute - let entities = + let catalogue = assemblyContentProvider.GetAllEntitiesInProjectAndReferencedAssemblies checkResults + + let casesInScope = HashSet(StringComparer.Ordinal) + let sourceLine = line.ToString() + + match ParsedInput.TryGetCompletionContext(unresolvedIdentRange.End, parseResults.ParseTree, sourceLine) with + | Some(CompletionContext.Pattern _) -> + context.CancellationToken.ThrowIfCancellationRequested() + + let cases = + [ + for symbol in catalogue do + if symbol.Symbol :? FSharpActivePatternCase then + yield symbol + ] + + let partialName = + { QuickParse.GetPartialLongNameEx(sourceLine, linePos.Character - 1) with + QualifyingIdents = [] + PartialIdent = "" + LastDotPos = None + } + + let symbols = + checkResults.GetDeclarationListSymbols( + Some parseResults, + unresolvedIdentRange.EndLine, + sourceLine, + partialName, + getAllEntities = (fun () -> cases) + ) + + for group in symbols do + for symbol in group do + if symbol.Symbol :? FSharpActivePatternCase then + casesInScope.Add symbol.Symbol.FullName |> ignore + | _ -> () + + let entities = + catalogue |> Array.collect (fun s -> [| - yield s.TopRequireQualifiedAccessParent, s.AutoOpenParent, s.Namespace, s.CleanedIdents - if isAttribute then - let lastIdent = s.CleanedIdents.[s.CleanedIdents.Length - 1] - - if - lastIdent.EndsWith "Attribute" - && s.Kind LookupType.Precise = EntityKind.Attribute - then - yield - s.TopRequireQualifiedAccessParent, - s.AutoOpenParent, - s.Namespace, - s.CleanedIdents - |> Array.replace - (s.CleanedIdents.Length - 1) - (lastIdent.Substring(0, lastIdent.Length - 9)) + if not (s.Symbol :? FSharpActivePatternCase) || casesInScope.Contains s.FullName then + yield s, s.CleanedIdents + + if isAttribute then + let lastIdent = s.CleanedIdents.[s.CleanedIdents.Length - 1] + + if + lastIdent.EndsWith "Attribute" + && s.Kind LookupType.Precise = EntityKind.Attribute + then + yield + s, + s.CleanedIdents + |> Array.replace + (s.CleanedIdents.Length - 1) + (lastIdent.Substring(0, lastIdent.Length - 9)) |]) ParsedInput.GetLongIdentAt parseResults.ParseTree unresolvedIdentRange.End @@ -204,9 +245,26 @@ type internal AddOpenCodeFixProvider [] (assemblyContentPr maybeUnresolvedIdents insertionPoint + let patternName = + longIdent + |> List.map (fun ident -> PrettyNaming.NormalizeIdentifierBackticks ident.idText) + |> String.concat "." + entities - |> Seq.map createEntity - |> Seq.concat + |> Seq.collect (fun (symbol, idents) -> + createEntity (symbol.TopRequireQualifiedAccessParent, symbol.AutoOpenParent, symbol.Namespace, idents) + |> Seq.map (fun (entity, insertionContext) -> + let entity = + if + symbol.Symbol :? FSharpActivePatternCase + && entity.FullDisplayName <> "" + && entity.FullDisplayName <> patternName + then + { entity with Namespace = None } + else + entity + + entity, insertionContext)) |> Seq.toList |> getSuggestionsAsCodeFixes context sourceText |> Seq.tryHead)) diff --git a/vsintegration/src/FSharp.Editor/LanguageService/AssemblyContentProvider.fs b/vsintegration/src/FSharp.Editor/LanguageService/AssemblyContentProvider.fs index 7a4b39c6737..967907641f7 100644 --- a/vsintegration/src/FSharp.Editor/LanguageService/AssemblyContentProvider.fs +++ b/vsintegration/src/FSharp.Editor/LanguageService/AssemblyContentProvider.fs @@ -4,6 +4,7 @@ namespace Microsoft.VisualStudio.FSharp.Editor open System open System.ComponentModel.Composition +open System.Runtime.CompilerServices open FSharp.Compiler.CodeAnalysis open FSharp.Compiler.EditorServices @@ -12,9 +13,19 @@ open FSharp.Compiler.EditorServices type internal AssemblyContentProvider() = let entityCache = EntityCache() + let projectContent = + ConditionalWeakTable>() + member _.GetAllEntitiesInProjectAndReferencedAssemblies(fileCheckResults: FSharpCheckFileResults) = [| - yield! AssemblyContent.GetAssemblySignatureContent AssemblyContentType.Full fileCheckResults.PartialAssemblySignature + yield! + projectContent + .GetValue( + fileCheckResults, + fun results -> + lazy (AssemblyContent.GetAssemblySignatureContent AssemblyContentType.Full results.PartialAssemblySignature) + ) + .Value // FCS sometimes returns several FSharpAssembly for single referenced assembly. // For example, it returns two different ones for Swensen.Unquote; the first one // contains no useful entities, the second one does. Our cache prevents to process diff --git a/vsintegration/tests/FSharp.Editor.Tests/ActivePatternEditorTests.fs b/vsintegration/tests/FSharp.Editor.Tests/ActivePatternEditorTests.fs new file mode 100644 index 00000000000..dc9c59d884b --- /dev/null +++ b/vsintegration/tests/FSharp.Editor.Tests/ActivePatternEditorTests.fs @@ -0,0 +1,284 @@ +module FSharp.Editor.Tests.ActivePatternEditorTests + +open System +open System.Collections.Immutable +open System.Threading + +open Microsoft.CodeAnalysis.Completion +open Microsoft.CodeAnalysis.Text +open Microsoft.VisualStudio.FSharp.Editor +open Microsoft.VisualStudio.FSharp.Editor.CancellableTasks +open Microsoft.VisualStudio.Shell +open Microsoft.VisualStudio.Shell.Interop + +open FSharp.Editor.Tests.CodeFixes.CodeFixTestFramework +open FSharp.Editor.Tests.Helpers +open Xunit + +let private definitions = + """namespace Candidates + +module Normal = + let (|Even|Odd|) value = if value % 2 = 0 then Even value else Odd value + let (|Positive|_|) value = if value > 0 then Some value else None + let (|Above|_|) threshold value = if value > threshold then Some value else None + let internal (|Internal|_|) value = Some value + let private (|Private|_|) value = Some value + [] + let (|Hidden|_|) value = Some value + [] + let (|Old|_|) value = Some value + +module Other = + let (|Positive|_|) value = Some value + +module private PrivateModule = + let (|Secret|_|) value = Some value + +[] +module Auto = + let (|AutoCase|_|) value = Some value + [] + module Nested = + let (|Deep|_|) value = Some value + module Ordinary = + let (|OrdinaryCase|_|) value = Some value + +[] +module Qualified = + let (|Restricted|_|) value = Some value + +[] +module Suffix = + let (|SuffixCase|_|) value = Some value + +module ``Space module`` = + let (|``Has space``|_|) value = Some value + +""" + +let private source (body: string) = + definitions + $"namespace Consumer\n\nmodule Use =\n\n {body}\n" + +let private withOpen atTop (ns: string) (code: string) = + if atTop then + code.Replace("namespace Consumer\n\n", $"namespace Consumer\n\nopen {ns}\n\n") + else + code.Replace("module Use =\n\n", $"module Use =\n\n open {ns}\n\n") + +let private assertCompiles code = + let document = RoslynTestHelpers.GetFsDocument code + + let _, results = + document.GetFSharpParseAndCheckResultsAsync(nameof AddOpenCodeFixProvider) + |> CancellableTask.runSynchronouslyWithoutCancellation + + Assert.Empty results.Diagnostics + +[] +[] +[] +[] +[] +[] +[] +[] +[] +[] +let ``Add Open applied case uses exact target and placement`` (caseName: string, parameters: string, ns: string, atTop: bool) = + let code = + source $"let classify value = match value with | {caseName}{parameters} n -> n | _ -> 0" + + let provider = AddOpenCodeFixProvider(AssemblyContentProvider()) + + let mode = + WithSettings + { CodeFixesOptions.Default with + AlwaysPlaceOpensAtTopLevel = atTop + } + + let fix = provider |> tryFix code mode |> Option.get + Assert.Equal($"open {ns}", fix.Message) + Assert.Equal(withOpen atTop ns code, fix.FixedCode.Replace("\r\n", "\n")) + assertCompiles fix.FixedCode + Assert.Equal(None, provider |> tryFix fix.FixedCode mode) + +[] +[] +[] +[] +let ``RQA case fix supplies the qualification still required`` (pattern: string, canOpen: bool) = + let code = + source $"let classify value = match value with | {pattern} n -> n | _ -> 0" + + let fix = + AddOpenCodeFixProvider(AssemblyContentProvider()) + |> tryFix code Auto + |> Option.get + + let expected = + if canOpen then + Assert.Equal("open Candidates", fix.Message) + withOpen true "Candidates" code + else + Assert.Equal("Candidates.Qualified.Restricted", fix.Message) + code.Replace("| Restricted n", "| Candidates.Qualified.Restricted n") + + Assert.Equal(expected, fix.FixedCode.Replace("\r\n", "\n")) + assertCompiles fix.FixedCode + +[] +[] +[ n | _ -> 0")>] +[ n | _ -> 0")>] +[