diff --git a/.vscode/launch.json b/.vscode/launch.json index c5ba1a784..9237446c0 100644 --- a/.vscode/launch.json +++ b/.vscode/launch.json @@ -78,7 +78,7 @@ "args": [ "--debug", "--filter", - "FSAC.lsp.${input:loader}.${input:testName}" + "FSAC.lsp.${input:loader}.${input:lsp-server}.${input:testName}" ] } ], @@ -103,6 +103,17 @@ "default": "WorkspaceLoader", "type": "pickString" }, + + { + "id": "lsp-server", + "description": "The lsp serrver", + "options": [ + "FSharpLspServer", + "AdaptiveLspServer" + ], + "default": "FSharpLspServer", + "type": "pickString" + }, { "id": "testName", "description": "the name of the test as provided to `testCase`", diff --git a/build.cmd b/build.cmd index 30a7bdf75..ed093c92c 100644 --- a/build.cmd +++ b/build.cmd @@ -1,2 +1,2 @@ dotnet tool restore -dotnet run --project build -t ReleaseArchive +dotnet run --project ./build/build.fsproj -- -t %* diff --git a/build/Program.fs b/build/Program.fs index b2104f594..bc294ca05 100644 --- a/build/Program.fs +++ b/build/Program.fs @@ -228,9 +228,7 @@ let main args = init ((args |> List.ofArray)) try - match args with - | [| target |] -> Target.runOrDefaultWithArguments target - | _ -> Target.runOrDefaultWithArguments "Test" + Target.runOrDefaultWithArguments "ReleaseArchive" 0 with e -> diff --git a/paket.dependencies b/paket.dependencies index 8a1ceaeb6..4b3ee1826 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -41,6 +41,7 @@ nuget System.CommandLine prerelease nuget FSharp.Data.Adaptive nuget Microsoft.NET.Test.Sdk nuget Dotnet.ReproducibleBuilds copy_local:true +nuget NuGet.Frameworks copy_local:false nuget Microsoft.NETFramework.ReferenceAssemblies nuget Ionide.KeepAChangelog.Tasks copy_local: true @@ -50,6 +51,7 @@ nuget YoloDev.Expecto.TestSdk nuget AltCover nuget GitHubActionsTestLogger nuget Ionide.LanguageServerProtocol +nuget Microsoft.Extensions.Caching.Memory group Build source https://api.nuget.org/v3/index.json diff --git a/paket.lock b/paket.lock index 89e2382c6..99b7fb65e 100644 --- a/paket.lock +++ b/paket.lock @@ -100,7 +100,7 @@ NUGET System.Collections.Immutable (>= 5.0) System.Reflection.Metadata (>= 5.0) Ionide.KeepAChangelog.Tasks (0.1.8) - copy_local: true - Ionide.LanguageServerProtocol (0.4.10) + Ionide.LanguageServerProtocol (0.4.11) FSharp.Core (>= 6.0) Newtonsoft.Json (>= 13.0.1) StreamJsonRpc (>= 2.10.44) @@ -176,12 +176,33 @@ NUGET System.Text.Encoding.CodePages (>= 4.0.1) - restriction: || (&& (== net7.0) (< net6.0)) (== netstandard2.0) Microsoft.CodeCoverage (17.3) - restriction: || (== net6.0) (== net7.0) (&& (== netstandard2.0) (>= net45)) (&& (== netstandard2.0) (>= netcoreapp1.0)) Microsoft.DotNet.PlatformAbstractions (3.1.6) - restriction: || (== net6.0) (== net7.0) (&& (== netstandard2.0) (>= net5.0)) + Microsoft.Extensions.Caching.Abstractions (6.0) + Microsoft.Extensions.Primitives (>= 6.0) + Microsoft.Extensions.Caching.Memory (6.0.1) + Microsoft.Extensions.Caching.Abstractions (>= 6.0) + Microsoft.Extensions.DependencyInjection.Abstractions (>= 6.0) + Microsoft.Extensions.Logging.Abstractions (>= 6.0) + Microsoft.Extensions.Options (>= 6.0) + Microsoft.Extensions.Primitives (>= 6.0) + Microsoft.Extensions.DependencyInjection.Abstractions (6.0) + Microsoft.Bcl.AsyncInterfaces (>= 6.0) - restriction: || (&& (== net6.0) (>= net461)) (&& (== net6.0) (< netstandard2.1)) (&& (== net7.0) (>= net461)) (&& (== net7.0) (< netstandard2.1)) (== netstandard2.0) + System.Threading.Tasks.Extensions (>= 4.5.4) - restriction: || (&& (== net6.0) (>= net461)) (&& (== net6.0) (< netstandard2.1)) (&& (== net7.0) (>= net461)) (&& (== net7.0) (< netstandard2.1)) (== netstandard2.0) Microsoft.Extensions.DependencyModel (6.0) - restriction: || (== net6.0) (== net7.0) (&& (== netstandard2.0) (>= net5.0)) System.Buffers (>= 4.5.1) System.Memory (>= 4.5.4) System.Runtime.CompilerServices.Unsafe (>= 6.0) System.Text.Encodings.Web (>= 6.0) System.Text.Json (>= 6.0) + Microsoft.Extensions.Logging.Abstractions (6.0.2) + System.Buffers (>= 4.5.1) - restriction: || (&& (== net6.0) (>= net461)) (&& (== net7.0) (>= net461)) (&& (== net7.0) (< net6.0)) (== netstandard2.0) + System.Memory (>= 4.5.4) - restriction: || (&& (== net6.0) (>= net461)) (&& (== net7.0) (>= net461)) (&& (== net7.0) (< net6.0)) (== netstandard2.0) + Microsoft.Extensions.Options (6.0) + Microsoft.Extensions.DependencyInjection.Abstractions (>= 6.0) + Microsoft.Extensions.Primitives (>= 6.0) + System.ComponentModel.Annotations (>= 5.0) - restriction: || (&& (== net6.0) (< netstandard2.1)) (&& (== net7.0) (< netstandard2.1)) (== netstandard2.0) + Microsoft.Extensions.Primitives (6.0) + System.Memory (>= 4.5.4) - restriction: || (&& (== net6.0) (>= net461)) (&& (== net6.0) (< netcoreapp3.1)) (&& (== net7.0) (>= net461)) (&& (== net7.0) (< netcoreapp3.1)) (== netstandard2.0) + System.Runtime.CompilerServices.Unsafe (>= 6.0) Microsoft.NET.StringTools (17.3.1) - copy_local: false System.Memory (>= 4.5.5) System.Runtime.CompilerServices.Unsafe (>= 6.0) @@ -235,8 +256,8 @@ NUGET Microsoft.VisualStudio.Validation (>= 16.10.26) System.IO.Pipelines (>= 5.0.1) System.Runtime.CompilerServices.Unsafe (>= 5.0) - Newtonsoft.Json (13.0.1) - NuGet.Frameworks (6.3) + Newtonsoft.Json (13.0.2) + NuGet.Frameworks (6.3) - copy_local: false runtime.debian.8-x64.runtime.native.System.Security.Cryptography.OpenSsl (4.3.3) runtime.debian.9-x64.runtime.native.System.Security.Cryptography.OpenSsl (4.3.3) runtime.fedora.23-x64.runtime.native.System.Security.Cryptography.OpenSsl (4.3.3) @@ -319,6 +340,7 @@ NUGET System.Runtime.CompilerServices.Unsafe (>= 6.0) System.CommandLine (2.0.0-beta4.22272.1) System.Memory (>= 4.5.4) - restriction: || (&& (== net7.0) (< net6.0)) (== netstandard2.0) + System.ComponentModel.Annotations (5.0) - restriction: || (&& (== net6.0) (< netstandard2.1)) (&& (== net7.0) (< netstandard2.1)) (== netstandard2.0) System.Configuration.ConfigurationManager (6.0) System.Security.Cryptography.ProtectedData (>= 6.0) System.Security.Permissions (>= 6.0) diff --git a/src/FsAutoComplete.Core/CodeGeneration.fs b/src/FsAutoComplete.Core/CodeGeneration.fs index b5e9056dd..a990c2e9d 100644 --- a/src/FsAutoComplete.Core/CodeGeneration.fs +++ b/src/FsAutoComplete.Core/CodeGeneration.fs @@ -1,4 +1,4 @@ -/// Original code from VisualFSharpPowerTools project: https://github.com/fsprojects/VisualFSharpPowerTools/blob/master/src/FSharp.Editing/CodeGeneration/CodeGeneration.fs +// Original code from VisualFSharpPowerTools project: https://github.com/fsprojects/VisualFSharpPowerTools/blob/master/src/FSharp.Editing/CodeGeneration/CodeGeneration.fs namespace FsAutoComplete open System diff --git a/src/FsAutoComplete.Core/Commands.fs b/src/FsAutoComplete.Core/Commands.fs index 3433211fd..c0e4d54a4 100644 --- a/src/FsAutoComplete.Core/Commands.fs +++ b/src/FsAutoComplete.Core/Commands.fs @@ -713,11 +713,9 @@ module Commands = let getSymbolUsesInProjects (symbol, projects: FSharpProjectOptions list, onFound) = projects - |> List.map (fun p -> - asyncResult { - for file in p.SourceFiles do - do! findReferencesInFile (file, symbol, p, onFound) - }) + |> List.collect (fun p -> + [ for file in p.SourceFiles do + yield findReferencesInFile (file, symbol, p, onFound) ]) |> Async.Parallel |> Async.map (Array.toList >> FsToolkit.ErrorHandling.List.sequenceResultM) @@ -770,9 +768,9 @@ module Commands = let symbolRange = symbol.DefinitionRange.NormalizeDriveLetterCasing() let symbolFile = symbolRange.TaggedFileName - let symbolFileText = + let! symbolFileText = tryGetFileSource (symbolFile) - |> Result.fold id (fun e -> failwith $"Unable to get file source for file '{symbolFile}'") + |> Result.mapError (fun e -> e + $"Unable to get file source for file '{symbolFile}'") let! symbolText = symbolFileText.[symbolRange] // |> Result.fold id (fun e -> failwith "Unable to get text for initial symbol use") @@ -790,37 +788,40 @@ module Commands = |> List.distinctBy (fun x -> x.ProjectFileName) let onFound (symbolUseRange: range) = - async { + asyncResult { let symbolUseRange = symbolUseRange.NormalizeDriveLetterCasing() let symbolFile = symbolUseRange.TaggedFileName - let targetText = tryGetFileSource (symbolFile) - - match targetText with - | Error e -> () - | Ok sourceText -> - let sourceSpan = - sourceText.[symbolUseRange] - |> Result.fold id (fun e -> failwith "Unable to get text for symbol use") - - // There are two kinds of ranges we get back: - // * ranges that exactly match the short name of the symbol - // * ranges that are longer than the short name of the symbol, - // typically because we're talking about some kind of fully-qualified usage - // For the latter, we need to adjust the reported range to just be the portion - // of the fully-qualfied text that is the symbol name. - if sourceSpan = symbolText then - symbolUseRanges.Add symbolUseRange - else - match sourceSpan.IndexOf(symbolText) with - | -1 -> () - | n -> - if sourceSpan.Length >= n + symbolText.Length then - let startPos = symbolUseRange.Start.IncColumn n - let endPos = symbolUseRange.Start.IncColumn(n + symbolText.Length) - - let actualUseRange = Range.mkRange symbolUseRange.FileName startPos endPos - symbolUseRanges.Add actualUseRange + let! sourceText = tryGetFileSource (symbolFile) + + + let! sourceSpan = + sourceText.[symbolUseRange] + |> Result.mapError (fun e -> e + "Unable to get text for symbol use") + + // There are two kinds of ranges we get back: + // * ranges that exactly match the short name of the symbol + // * ranges that are longer than the short name of the symbol, + // typically because we're talking about some kind of fully-qualified usage + // For the latter, we need to adjust the reported range to just be the portion + // of the fully-qualfied text that is the symbol name. + if sourceSpan = symbolText then + symbolUseRanges.Add symbolUseRange + else + match sourceSpan.IndexOf(symbolText) with + | -1 -> () + | n -> + if sourceSpan.Length >= n + symbolText.Length then + let startPos = symbolUseRange.Start.IncColumn n + let endPos = symbolUseRange.Start.IncColumn(n + symbolText.Length) + + let actualUseRange = Range.mkRange symbolUseRange.FileName startPos endPos + symbolUseRanges.Add actualUseRange } + |> Async.map (fun x -> + match x with + | Ok () -> () + | Error e -> + commandsLogger.info (Log.setMessage "OnFound failed: {errpr}" >> Log.addContextDestructured "error" e)) let! _ = getSymbolUsesInProjects (symbol, projects, onFound) diff --git a/src/FsAutoComplete.Core/CompilerServiceInterface.fs b/src/FsAutoComplete.Core/CompilerServiceInterface.fs index d983c3037..899a286f8 100644 --- a/src/FsAutoComplete.Core/CompilerServiceInterface.fs +++ b/src/FsAutoComplete.Core/CompilerServiceInterface.fs @@ -9,6 +9,11 @@ open Ionide.ProjInfo.ProjectSystem open FSharp.UMX open FSharp.Compiler.EditorServices open FSharp.Compiler.Symbols +open Microsoft.Extensions.Caching.Memory +open System +open FsToolkit.ErrorHandling + + type Version = int @@ -24,8 +29,18 @@ type FSharpCompilerServiceChecker(hasAnalyzers) = keepAllBackgroundSymbolUses = true ) + + let entityCache = EntityCache() + // This is used to hold previous check results for autocompletion. + // We can't seem to rely on the checker for previous cached versions + let memoryCache () = + new MemoryCache(MemoryCacheOptions(SizeLimit = Nullable<_>(2000L))) + + let mutable lastCheckResults: IMemoryCache = memoryCache () + + let checkerLogger = LogProvider.getLoggerByName "Checker" let optsLogger = LogProvider.getLoggerByName "Opts" @@ -227,6 +242,14 @@ type FSharpCompilerServiceChecker(hasAnalyzers) = member __.ScriptTypecheckRequirementsChanged = scriptTypecheckRequirementsChanged.Publish + /// This function is called when the entire environment is known to have changed for reasons not encoded in the ProjectOptions of any project/compilation. + member _.ClearCaches() = + let oldlastCheckResults = lastCheckResults + lastCheckResults <- memoryCache () + oldlastCheckResults.Dispose() + checker.InvalidateAll() + checker.ClearLanguageServiceRootCachesAndCollectAndFinalizeAllTransients() + member __.ParseFile(fn: string, source, fpo) = checkerLogger.info (Log.setMessage "ParseFile - {file}" >> Log.addContextDestructured "file" fn) @@ -234,7 +257,7 @@ type FSharpCompilerServiceChecker(hasAnalyzers) = checker.ParseFile(path, source, fpo) member __.ParseAndCheckFileInProject(filePath: string, version, source: ISourceText, options) = - async { + asyncResult { let opName = sprintf "ParseAndCheckFileInProject - %A" filePath checkerLogger.info (Log.setMessage "{opName}" >> Log.addContextDestructured "opName" opName) @@ -255,18 +278,34 @@ type FSharpCompilerServiceChecker(hasAnalyzers) = >> Log.addContextDestructured "errors" (List.ofArray p.Diagnostics) ) - return ResultOrString.Error(sprintf "Check aborted (%A). Errors: %A" c parseErrors) + return! ResultOrString.Error(sprintf "Check aborted (%A). Errors: %A" c parseErrors) | FSharpCheckFileAnswer.Succeeded (c) -> checkerLogger.info ( Log.setMessage "{opName} completed successfully" >> Log.addContextDestructured "opName" opName ) - return Ok(ParseAndCheckResults(p, c, entityCache)) + let r = ParseAndCheckResults(p, c, entityCache) + + let ops = + MemoryCacheEntryOptions() + .SetSize(1) + .SetSlidingExpiration(TimeSpan.FromMinutes(5.)) + + return lastCheckResults.Set(filePath, r, ops) with ex -> - return ResultOrString.Error(ex.ToString()) + return! ResultOrString.Error(ex.ToString()) } + member _.TryGetLastCheckResultForFile(file: string) = + let opName = sprintf "TryGetLastCheckResultForFile - %A" file + + checkerLogger.info (Log.setMessage "{opName}" >> Log.addContextDestructured "opName" opName) + + match lastCheckResults.TryGetValue(file) with + | (true, v) -> Some v + | _ -> None + member __.TryGetRecentCheckResultsForFile(file: string, options, source: ISourceText) = let opName = sprintf "TryGetRecentCheckResultsForFile - %A" file @@ -274,13 +313,21 @@ type FSharpCompilerServiceChecker(hasAnalyzers) = Log.setMessage "{opName} - {hash}" >> Log.addContextDestructured "opName" opName >> Log.addContextDestructured "hash" (source.GetHashCode() |> int) + ) let options = clearProjectReferences options let result = checker.TryGetRecentCheckResultsForFile(UMX.untag file, options, sourceText = source, userOpName = opName) - |> Option.map (fun (pr, cr, _) -> ParseAndCheckResults(pr, cr, entityCache)) + |> Option.map (fun (pr, cr, version) -> + checkerLogger.info ( + Log.setMessage "{opName} - got results - {version}" + >> Log.addContextDestructured "opName" opName + >> Log.addContextDestructured "version" version + ) + + ParseAndCheckResults(pr, cr, entityCache)) checkerLogger.info ( Log.setMessage "{opName} - {hash} - cacheHit {cacheHit}" diff --git a/src/FsAutoComplete.Core/FileSystem.fs b/src/FsAutoComplete.Core/FileSystem.fs index e8b2b9b30..0159ed758 100644 --- a/src/FsAutoComplete.Core/FileSystem.fs +++ b/src/FsAutoComplete.Core/FileSystem.fs @@ -144,7 +144,7 @@ type NamedText(fileName: string, str: string) = // because we know there are lines after the first line let firstLine = (x :> ISourceText).GetLineString(m.StartLine - 1) - builder.AppendLine(firstLine.Substring(m.StartColumn)) + builder.AppendLine(firstLine.Substring(Math.Min(firstLine.Length, m.StartColumn))) |> ignore // whole intermediate lines, including newlines @@ -155,7 +155,7 @@ type NamedText(fileName: string, str: string) = // final part, potential slice, so we do not include the trailing newline let lastLine = (x :> ISourceText).GetLineString(m.EndLine - 1) - builder.Append(lastLine.Substring(0, m.EndColumn)) + builder.Append(lastLine.Substring(0, Math.Min(lastLine.Length, m.EndColumn))) |> ignore Ok(builder.ToString()) @@ -260,8 +260,8 @@ type NamedText(fileName: string, str: string) = member x.ModifyText(m: FSharp.Compiler.Text.Range, text: string) : Result = result { let startRange, endRange = x.SplitAt(m) - let! startText = x[startRange] - let! endText = x[endRange] + let! startText = x[startRange] |> Result.mapError (fun x -> $"startRange -> {x}") + and! endText = x[endRange] |> Result.mapError (fun x -> $"endRange -> {x}") let totalText = startText + text + endText return NamedText(x.FileName, totalText) } @@ -355,6 +355,8 @@ type VolatileFile = Lines: NamedText Version: int option } + member this.FileName = this.Lines.FileName + /// Updates the Lines value member this.SetLines(lines) = { this with Lines = lines } @@ -407,11 +409,18 @@ type FileSystem(actualFs: IFileSystem, tryFindFile: string -> Volatil let fsLogger = LogProvider.getLoggerByName "FileSystem" let getContent (filename: string) = - fsLogger.debug (Log.setMessage "Getting content of `{path}`" >> Log.addContext "path" filename) + filename |> tryFindFile - |> Option.map (fun file -> file.Lines.ToString() |> System.Text.Encoding.UTF8.GetBytes) + |> Option.map (fun file -> + fsLogger.debug ( + Log.setMessage "Getting content of `{path}` - {hash}" + >> Log.addContext "path" filename + >> Log.addContext "hash" (file.Lines.GetHashCode()) + ) + + file.Lines.ToString() |> System.Text.Encoding.UTF8.GetBytes) /// translation of the BCL's Windows logic for Path.IsPathRooted. /// @@ -455,12 +464,21 @@ type FileSystem(actualFs: IFileSystem, tryFindFile: string -> Volatil expanded - member _.GetLastWriteTimeShim(f: string) = - f - |> Utils.normalizePath - |> tryFindFile - |> Option.map (fun f -> f.Touched) - |> Option.defaultWith (fun () -> actualFs.GetLastWriteTimeShim f) + member _.GetLastWriteTimeShim(filename: string) = + let result = + filename + |> Utils.normalizePath + |> tryFindFile + |> Option.map (fun f -> f.Touched) + |> Option.defaultWith (fun () -> actualFs.GetLastWriteTimeShim filename) + + // fsLogger.debug ( + // Log.setMessage "GetLastWriteTimeShim of `{path}` - {date} " + // >> Log.addContext "path" filename + // >> Log.addContext "date" result + // ) + + result member _.NormalizePathShim(f: string) = f |> Utils.normalizePath |> UMX.untag diff --git a/src/FsAutoComplete.Core/Lexer.fs b/src/FsAutoComplete.Core/Lexer.fs index 88f831ef9..0d1303b4f 100644 --- a/src/FsAutoComplete.Core/Lexer.fs +++ b/src/FsAutoComplete.Core/Lexer.fs @@ -247,7 +247,7 @@ module Lexer = | StaticallyResolvedTypeParameter | Keyword -> true | _ -> false) - /// Gets the option if Some x, otherwise try to get another value + // Gets the option if Some x, otherwise try to get another value |> Option.orElseWith (fun _ -> tokensUnderCursor |> List.tryFind (fun { DraftToken.Kind = k } -> k = Operator)) |> Option.map (fun token -> diff --git a/src/FsAutoComplete.Core/ParseAndCheckResults.fs b/src/FsAutoComplete.Core/ParseAndCheckResults.fs index fbf6d1a0d..fa39c0c78 100644 --- a/src/FsAutoComplete.Core/ParseAndCheckResults.fs +++ b/src/FsAutoComplete.Core/ParseAndCheckResults.fs @@ -549,6 +549,11 @@ type ParseAndCheckResults let residue = longName.PartialIdent + logger.info ( + Log.setMessage "TryGetCompletions - lineStr: {lineStr}" + >> Log.addContextDestructured "lineStr" lineStr + ) + logger.info ( Log.setMessage "TryGetCompletions - long name: {longName}" >> Log.addContextDestructured "longName" longName @@ -581,9 +586,8 @@ type ParseAndCheckResults | Some k when k.Kind = Operator -> return None | Some k when k.Kind = Keyword -> return None | _ -> - let results = - checkResults.GetDeclarationListInfo(Some parseResults, pos.Line, lineStr, longName, getAllSymbols) + checkResults.GetDeclarationListInfo(Some parseResults, pos.Line, lineStr, longName, getSymbols) let getKindPriority = function diff --git a/src/FsAutoComplete.Core/TypedAstPatterns.fs b/src/FsAutoComplete.Core/TypedAstPatterns.fs index 1a623f9dd..babdedd74 100644 --- a/src/FsAutoComplete.Core/TypedAstPatterns.fs +++ b/src/FsAutoComplete.Core/TypedAstPatterns.fs @@ -253,8 +253,8 @@ module SymbolUse = | Entity (entity, _) when entity.IsAttributeType -> Some entity | _ -> None -[] /// Active patterns over `FSharpSymbol`. +[] module SymbolPatterns = let private attributeSuffixLength = "Attribute".Length diff --git a/src/FsAutoComplete.Core/TypedAstUtils.fs b/src/FsAutoComplete.Core/TypedAstUtils.fs index 63d0d8871..2ae1b3601 100644 --- a/src/FsAutoComplete.Core/TypedAstUtils.fs +++ b/src/FsAutoComplete.Core/TypedAstUtils.fs @@ -1,4 +1,4 @@ -///Original code from VisualFSharpPowerTools project: https://github.com/fsprojects/VisualFSharpPowerTools/blob/master/src/FSharp.Editing/Common/TypedAstUtils.fs +//Original code from VisualFSharpPowerTools project: https://github.com/fsprojects/VisualFSharpPowerTools/blob/master/src/FSharp.Editing/Common/TypedAstUtils.fs namespace FsAutoComplete open System diff --git a/src/FsAutoComplete.Core/paket.references b/src/FsAutoComplete.Core/paket.references index 2290a3a13..323acb9d2 100644 --- a/src/FsAutoComplete.Core/paket.references +++ b/src/FsAutoComplete.Core/paket.references @@ -13,3 +13,4 @@ System.Reflection.Metadata Microsoft.Build.Utilities.Core Ionide.LanguageServerProtocol Ionide.KeepAChangelog.Tasks +Microsoft.Extensions.Caching.Memory diff --git a/src/FsAutoComplete/CodeFixes.fs b/src/FsAutoComplete/CodeFixes.fs index b6cde1051..378b0e289 100644 --- a/src/FsAutoComplete/CodeFixes.fs +++ b/src/FsAutoComplete/CodeFixes.fs @@ -1,5 +1,5 @@ -/// This module contains the logic for codefixes that FSAC surfaces, as well as conversion logic between -/// compiler diagnostics and LSP diagnostics/code actions +// This module contains the logic for codefixes that FSAC surfaces, as well as conversion logic between +// compiler diagnostics and LSP diagnostics/code actions namespace FsAutoComplete.CodeFix open FsAutoComplete diff --git a/src/FsAutoComplete/CodeFixes/ResolveNamespace.fs b/src/FsAutoComplete/CodeFixes/ResolveNamespace.fs index a76bdff02..bd5522bed 100644 --- a/src/FsAutoComplete/CodeFixes/ResolveNamespace.fs +++ b/src/FsAutoComplete/CodeFixes/ResolveNamespace.fs @@ -30,29 +30,38 @@ let fix let adjustInsertionPoint (lines: ISourceText) (ctx: InsertionContext) = let l = ctx.Pos.Line - match ctx.ScopeKind with - | ScopeKind.TopModule when l > 1 -> - let line = lines.GetLineString(l - 2) - - let isImplicitTopLevelModule = - not (line.StartsWith "module" && not (line.EndsWith "=")) - - if isImplicitTopLevelModule then 1 else l - | ScopeKind.TopModule -> 1 - | ScopeKind.Namespace -> - let mostRecentNamespaceInScope = - let lineNos = if l = 0 then [] else [ 0 .. l - 1 ] - - lineNos - |> List.mapi (fun i line -> i, lines.GetLineString line) - |> List.choose (fun (i, lineStr) -> if lineStr.StartsWith "namespace" then Some i else None) - |> List.tryLast - - match mostRecentNamespaceInScope with - // move to the next line below "namespace" and convert it to F# 1-based line number - | Some line -> line + 2 - | None -> l - | _ -> l + let retVal = + match ctx.ScopeKind with + | ScopeKind.TopModule when l > 1 -> + let line = lines.GetLineString(l - 2) + + let isImplicitTopLevelModule = + not (line.StartsWith "module" && not (line.EndsWith "=")) + + if isImplicitTopLevelModule then 1 else l + | ScopeKind.TopModule -> 1 + | ScopeKind.Namespace -> + let mostRecentNamespaceInScope = + let lineNos = if l = 0 then [] else [ 0 .. l - 1 ] + + lineNos + |> List.mapi (fun i line -> i, lines.GetLineString line) + |> List.choose (fun (i, lineStr) -> if lineStr.StartsWith "namespace" then Some i else None) + |> List.tryLast + + match mostRecentNamespaceInScope with + // move to the next line below "namespace" and convert it to F# 1-based line number + | Some line -> line + 2 + | None -> l + | _ -> l + + let containsAttribute (x: string) = x.Contains "[<" + let currentLine = System.Math.Max(retVal - 2, 0) |> lines.GetLineString + + if currentLine |> containsAttribute then + retVal + 1 + else + retVal let qualifierFix file diagnostic qual = { SourceDiagnostic = Some diagnostic @@ -76,22 +85,26 @@ let fix ns let lineStr = - let whitespace = String.replicate ctx.Pos.Column " " + let whitespace = + let column = + // HACK: This is a work around for inheriting the correct column of the current module + // It seems the column we get from FCS is incorrect + let previousLine = docLine - 1 + let insertionPointIsNotOutOfBoundsOfTheFile = docLine > 0 + + let theThereAreOtherOpensInThisModule () = + text.GetLineString(previousLine).Contains "open " + + if insertionPointIsNotOutOfBoundsOfTheFile && theThereAreOtherOpensInThisModule () then + text.GetLineString(previousLine).Split("open") |> Seq.head |> Seq.length // inherit the previous opens whitespace + else + ctx.Pos.Column + + String.replicate column " " + $"%s{whitespace}open %s{actualOpen}\n" - let edits = - [| yield insertLine docLine lineStr - if - text.GetLineCount() < docLine + 1 - && text.GetLineString(docLine + 1).Trim() <> "" - then - yield insertLine (docLine + 1) "" - if - (ctx.Pos.Column = 0 || ctx.ScopeKind = ScopeKind.Namespace) - && docLine > 0 - && not (text.GetLineString(docLine - 1).StartsWith "open") - then - yield insertLine (docLine - 1) "" |] + let edits = [| yield insertLine docLine lineStr |] { Edits = edits File = file diff --git a/src/FsAutoComplete/FsAutoComplete.fsproj b/src/FsAutoComplete/FsAutoComplete.fsproj index 57e1558a6..6815613b5 100644 --- a/src/FsAutoComplete/FsAutoComplete.fsproj +++ b/src/FsAutoComplete/FsAutoComplete.fsproj @@ -45,7 +45,7 @@ DotnetTool - Major + LatestMajor $(TargetsForTfmSpecificBuildOutput);CopyProjectReferencesToPackage diff --git a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs index 94e7ca004..c9adac7b9 100644 --- a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs +++ b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs @@ -9,8 +9,8 @@ open FsAutoComplete.CodeFix open FsAutoComplete.CodeFix.Types open FsAutoComplete.Logging open Ionide.LanguageServerProtocol -open Ionide.LanguageServerProtocol.Types.LspResult open Ionide.LanguageServerProtocol.Server +open Ionide.LanguageServerProtocol.Types.LspResult open Ionide.LanguageServerProtocol.Types open Newtonsoft.Json.Linq open Ionide.ProjInfo.ProjectSystem @@ -30,9 +30,6 @@ open Fantomas.Client.LSPFantomasService open FSharp.Data.Adaptive open Ionide.ProjInfo open FSharp.Compiler.CodeAnalysis -open System.Linq - -open System.Reactive.Linq open FsAutoComplete.LspHelpers open FsAutoComplete.UnionPatternMatchCaseGenerator @@ -151,7 +148,7 @@ module AMap = } /// Adaptively looks up the given key in the map and binds the value to be easily worked with. Note that this operation should not be used extensively since its resulting aval will be re-evaluated upon every change of the map. - let tryFindA key (map: amap<_, aval<'b>>) = + let tryFindA key (map: amap<_, #aval<'b>>) = aval { let! item = AMap.tryFind key map @@ -162,9 +159,10 @@ module AMap = | None -> return None } + /// Adaptively applies the given mapping function to all elements and returns a new amap containing the results. - let mapAdaptiveValue mapper (map: amap<_, aval<'b>>) = - map |> AMap.mapA (fun k v -> AVal.map mapper v) + let mapAVal (mapper: 'Key -> 'InValue -> aval<'OutValue>) (map: amap<'Key, aval<'InValue>>) = + map |> AMap.map (fun k v -> AVal.bind (mapper k) v) [] @@ -211,7 +209,6 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar transact (fun () -> config.Value <- c) mutableConfigChanges |> AVal.force - let tfmConfig = config |> AVal.map (fun c -> @@ -235,11 +232,11 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let diagnosticCollections = new DiagnosticCollection(sendDiagnostics) - let notifications = Event() + let notifications = Event() let scriptFileProjectOptions = Event() - let handleCommandEvents (n: NotificationEvent) = + let handleCommandEvents (n: NotificationEvent, ct: CancellationToken) = try async { try @@ -432,19 +429,20 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar () } - |> Async.RunSynchronouslyWithCT CancellationToken.None - + |> Async.RunSynchronouslyWithCT ct with :? OperationCanceledException as e -> () + do disposables.Add( (notifications.Publish :> IObservable<_>) - .BufferedDebounce(TimeSpan.FromMilliseconds(200.)) - .SelectMany(fun l -> l.Distinct()) + // .BufferedDebounce(TimeSpan.FromMilliseconds(200.)) + // .SelectMany(fun l -> l.Distinct()) .Subscribe(fun e -> handleCommandEvents e) ) + let adaptiveFile (filePath: string) = let file = AdaptiveFile.GetLastWriteTimeUtc(UMX.untag filePath) @@ -464,6 +462,21 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let rootPath = cval None + + let binlogConfig = + aval { + let! config = config + and! rootPath = rootPath + + match config.GenerateBinlog, rootPath with + | _, None + | false, _ -> return Ionide.ProjInfo.BinaryLogGeneration.Off + | true, Some rootPath -> + return Ionide.ProjInfo.BinaryLogGeneration.Within(DirectoryInfo(Path.Combine(rootPath, ".ionide"))) + } + + + // JB:TODO Adding to solution // JB:TODO Adding new project file not yet added to solution let workspacePaths: ChangeableValue = @@ -506,147 +519,278 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let glyphToSymbolKind = clientCapabilities |> AVal.map glyphToSymbolKindGenerator let loadedProjectOptions = - (loader, adaptiveWorkspacePaths) - ||> AVal.bind2 (fun loader wsp -> - aval { - match wsp with - | AdaptiveWorkspaceChosen.NotChosen -> return [] - | AdaptiveWorkspaceChosen.Sln _ -> return raise (NotImplementedException()) - | AdaptiveWorkspaceChosen.Directory _ -> return raise (NotImplementedException()) - | AdaptiveWorkspaceChosen.Projs projects -> - let! projectOptions = + aval { + let! loader = loader + and! wsp = adaptiveWorkspacePaths + + match wsp with + | AdaptiveWorkspaceChosen.NotChosen -> return [] + | AdaptiveWorkspaceChosen.Sln _ -> return raise (NotImplementedException()) + | AdaptiveWorkspaceChosen.Directory _ -> return raise (NotImplementedException()) + | AdaptiveWorkspaceChosen.Projs projects -> + let! binlogConfig = binlogConfig + + let! projectOptions = + projects + |> AVal.mapWithAdditionalDependenies (fun projects -> + projects - |> AVal.mapWithAdditionalDependenies (fun projects -> - - projects - |> Seq.iter (fun (proj: string, _) -> - UMX.untag proj - |> ProjectResponse.ProjectLoading - |> NotificationEvent.Workspace - |> notifications.Trigger) - - let projectOptions = - loader.LoadProjects(projects |> Seq.map (fst >> UMX.untag) |> Seq.toList) - |> Seq.toList - - for p in projectOptions do - logger.info ( - Log.setMessage "Found BaseIntermediateOutputPath of {path}" - >> Log.addContextDestructured "path" p.Properties - ) + |> Seq.iter (fun (proj: string, _) -> + let not = + UMX.untag proj |> ProjectResponse.ProjectLoading |> NotificationEvent.Workspace + + notifications.Trigger(not, CancellationToken.None)) - let additionalDependencies = + let projectOptions = + loader.LoadProjects(projects |> Seq.map (fst >> UMX.untag) |> Seq.toList, [], binlogConfig) + |> Seq.toList - [ for p in projectOptions do - match p.Properties |> Seq.tryFind (fun x -> x.Name = "ProjectAssetsFile") with - | Some v -> yield adaptiveFile (UMX.tag v.Value) - | None -> () + for p in projectOptions do + logger.info ( + Log.setMessage "Found BaseIntermediateOutputPath of {path}" + >> Log.addContextDestructured "path" p.Properties + ) - let objPath = - p.Properties - |> Seq.tryFind (fun x -> x.Name = "BaseIntermediateOutputPath") - |> Option.map (fun v -> v.Value) + let additionalDependencies = - let isWithinObjFolder (file: string) = - match objPath with - | None -> true // if no obj folder provided assume we should track this file - | Some v -> file.Contains(v) + [ for p in projectOptions do + match p.Properties |> Seq.tryFind (fun x -> x.Name = "ProjectAssetsFile") with + | Some v -> yield adaptiveFile (UMX.tag v.Value) + | None -> () - match p.Properties |> Seq.tryFind (fun x -> x.Name = "MSBuildAllProjects") with - | Some v -> - yield! - v.Value.Split(';', StringSplitOptions.RemoveEmptyEntries) - |> Array.filter (fun x -> x.EndsWith(".props") && isWithinObjFolder x) - |> Array.map (UMX.tag >> adaptiveFile) - | None -> () ] + let objPath = + p.Properties + |> Seq.tryFind (fun x -> x.Name = "BaseIntermediateOutputPath") + |> Option.map (fun v -> v.Value) - projectOptions, additionalDependencies) + let isWithinObjFolder (file: string) = + match objPath with + | None -> true // if no obj folder provided assume we should track this file + | Some v -> file.Contains(v) + match p.Properties |> Seq.tryFind (fun x -> x.Name = "MSBuildAllProjects") with + | Some v -> + yield! + v.Value.Split(';', StringSplitOptions.RemoveEmptyEntries) + |> Array.filter (fun x -> x.EndsWith(".props") && isWithinObjFolder x) + |> Array.map (UMX.tag >> adaptiveFile) + | None -> () ] - let options = - projectOptions - |> List.map (fun o -> - let fso = FCS.mapToFSharpProjectOptions o projectOptions + projectOptions, additionalDependencies) - fso, o) + and! checker = checker + checker.ClearCaches() // if we got new projects assume we're gonna need to clear caches - options - |> List.iter (fun (opts, extraInfo) -> - let projectFileName = opts.ProjectFileName - let projViewerItemsNormalized = ProjectViewer.render extraInfo + let options = + projectOptions + |> List.map (fun o -> + let fso = FCS.mapToFSharpProjectOptions o projectOptions - let responseFiles = - projViewerItemsNormalized.Items - |> List.map (function - | ProjectViewerItem.Compile (p, c) -> ProjectViewerItem.Compile(Helpers.fullPathNormalized p, c)) - |> List.choose (function - | ProjectViewerItem.Compile (p, _) -> Some p) + // Set some default values as FCS uses these for identification/caching purposes + let fso = + { fso with + Stamp = fso.Stamp |> Option.orElse (Some DateTime.UtcNow.Ticks) + ProjectId = fso.ProjectId |> Option.orElse (Some(Guid.NewGuid().ToString())) } - let references = FscArguments.references (opts.OtherOptions |> List.ofArray) + fso, o) - logger.info ( - Log.setMessage "ProjectLoaded {file}" - >> Log.addContextDestructured "file" projectFileName - ) + options + |> List.iter (fun (opts, extraInfo) -> + let projectFileName = opts.ProjectFileName + let projViewerItemsNormalized = ProjectViewer.render extraInfo - let ws = - { ProjectFileName = projectFileName - ProjectFiles = responseFiles - OutFileOpt = Option.ofObj extraInfo.TargetPath - References = references - Extra = extraInfo - ProjectItems = projViewerItemsNormalized.Items - Additionals = Map.empty } - - ProjectResponse.Project(ws, false) - |> NotificationEvent.Workspace - |> notifications.Trigger) - - ProjectResponse.WorkspaceLoad true - |> NotificationEvent.Workspace - |> notifications.Trigger - - return options |> List.map fst - }) + let responseFiles = + projViewerItemsNormalized.Items + |> List.map (function + | ProjectViewerItem.Compile (p, c) -> ProjectViewerItem.Compile(Helpers.fullPathNormalized p, c)) + |> List.choose (function + | ProjectViewerItem.Compile (p, _) -> Some p) + + let references = FscArguments.references (opts.OtherOptions |> List.ofArray) + + logger.info ( + Log.setMessage "ProjectLoaded {file}" + >> Log.addContextDestructured "file" projectFileName + ) + + let ws = + { ProjectFileName = projectFileName + ProjectFiles = responseFiles + OutFileOpt = Option.ofObj extraInfo.TargetPath + References = references + Extra = extraInfo + ProjectItems = projViewerItemsNormalized.Items + Additionals = Map.empty } + + let not = ProjectResponse.Project(ws, false) |> NotificationEvent.Workspace + notifications.Trigger(not, CancellationToken.None)) + + let not = ProjectResponse.WorkspaceLoad true |> NotificationEvent.Workspace + + notifications.Trigger(not, CancellationToken.None) + + return options |> List.map fst + } let fantomasLogger = LogProvider.getLoggerByName "Fantomas" let fantomasService: FantomasService = new LSPFantomasService() :> FantomasService - let openFiles = - cmap, cval> () + let openFilesTokens = cmap, cval> () + let openFiles = cmap, cval> () - let openFilesA = openFiles |> AMap.map' (fun v -> v :> aval<_>) + let textChanges = + cmap, cset> () - let cancelAllOpenFileCheckRequests () = - transact (fun () -> - let files = openFiles |> AMap.force + let textChangesReadOnly = textChanges |> AMap.map (fun _ x -> x :> aset<_>) + + let logTextChange (v: VolatileFile) = + logger.debug ( + Log.setMessage "TextChanged for file : {fileName} {touched} {version}" + >> Log.addContextDestructured "fileName" v.FileName + >> Log.addContextDestructured "touched" v.Touched + >> Log.addContextDestructured "version" v.Version + ) - for (_, fileVal) in files do - let (oldFile, cts: CancellationTokenSource) = fileVal |> AVal.force - cts.Cancel() - cts.Dispose() - fileVal.Value <- oldFile, new CancellationTokenSource()) + let tee f x = + f x + x - let updateOpenFiles (file: VolatileFile) = + let openFilesWithChanges: amap<_, aval> = + + openFiles + |> AMap.map (fun filePath file -> + aval { + let! (file) = file + and! changes = textChangesReadOnly |> AMap.tryFind filePath + + match changes with + | None -> return (file) + | Some c -> + let! ps = c |> ASet.toAVal + + let changes = + ps + |> Seq.sortBy (fun (x, _) -> x.TextDocument.Version.Value) + |> Seq.collect (fun (p, touched) -> + p.ContentChanges + |> Array.map (fun x -> x, p.TextDocument.Version.Value, touched)) - let adder _ = - cval (file, new CancellationTokenSource()) + let file = + (file, changes) + ||> Seq.fold (fun text (change, version, touched) -> + match change.Range with + | None -> // replace entire content + // We want to update the DateTime here since TextDocumentDidChange will not have changes reflected on disk + VolatileFile.Create(filePath, change.Text, Some version, touched) + | Some rangeToReplace -> + // replace just this slice + let fcsRangeToReplace = protocolRangeToRange (UMX.untag filePath) rangeToReplace + + try + match text.Lines.ModifyText(fcsRangeToReplace, change.Text) with + | Ok text -> VolatileFile.Create(text, Some version, touched) + + | Error message -> + logger.error ( + Log.setMessage + "Error applying {change} to document {file} for version {version} - {range} : {message} " + >> Log.addContextDestructured "file" filePath + >> Log.addContextDestructured "version" version + >> Log.addContextDestructured "message" message + >> Log.addContextDestructured "range" fcsRangeToReplace + >> Log.addContextDestructured "change" change + ) + + text + with e -> + logger.error ( + Log.setMessage "Error applying {change} to document {file} for version {version} - {range}" + >> Log.addContextDestructured "file" filePath + >> Log.addContextDestructured "range" fcsRangeToReplace + >> Log.addContextDestructured "version" version + >> Log.addContextDestructured "change" change + >> Log.addExn e + ) + + text) + + return (file) |> tee logTextChange + }) + + + let resetFileVal filePath (fileVal: cval<_>) = + let cts: CancellationTokenSource = fileVal |> AVal.force + + try + logger.info ( + Log.setMessage "Cancelling {filePath} - {version}" + >> Log.addContextDestructured "filePath" filePath + // >> Log.addContextDestructured "version" oldFile.Version + ) - let updater _ (v: cval<_>) = - let (oldFile, cts: CancellationTokenSource) = v.Value cts.Cancel() cts.Dispose() - v.Value <- file, new CancellationTokenSource() + with + | :? OperationCanceledException + | :? ObjectDisposedException as e when e.Message.Contains("CancellationTokenSource has been disposed") -> + // ignore if already cancelled + () + + transact (fun () -> fileVal.Value <- new CancellationTokenSource()) + + let resetCancellationToken filePath = + openFilesTokens + |> AMap.tryFind filePath + |> AVal.force + |> Option.iter (resetFileVal filePath) + + let adder _ = cval (new CancellationTokenSource()) + + let updater _ (v: cval<_>) = resetFileVal filePath v + + transact (fun () -> openFilesTokens.AddOrElse(filePath, adder, updater)) + + let resetAllCancellationTokens () = + let files = openFilesTokens |> AMap.force + + for (filePath, fileVal) in files do + resetFileVal filePath fileVal + + + let updateOpenFiles (file: VolatileFile) = + let adder _ = cval file + + let updater _ (v: cval<_>) = v.Value <- file + + transact (fun () -> + resetCancellationToken file.FileName + openFiles.AddOrElse(file.Lines.FileName, adder, updater)) + + let updateTextchanges filePath p = + let adder _ = cset<_> [ p ] + let updater _ (v: cset<_>) = v.Add p |> ignore + + transact (fun () -> + resetCancellationToken filePath + textChanges.AddOrElse(filePath, adder, updater)) - transact (fun () -> openFiles.AddOrElse(file.Lines.FileName, adder, updater)) + let isFileOpen file = + openFiles |> AMap.tryFindA file |> AVal.map (Option.isSome) - let findFileInOpenFiles file = openFilesA |> AMap.tryFindA file + let findFileInOpenFiles' file = + openFilesWithChanges |> AMap.tryFindA file + + let findFileInOpenFiles file = findFileInOpenFiles' file + + let forceFindOpenFile filePath = + findFileInOpenFiles filePath |> AVal.force let forceFindOpenFileOrRead file = findFileInOpenFiles file |> AVal.force |> Option.orElseWith (fun () -> + // TODO: Log how many times this kind area gets hit and possibly if this should be rethought try let untagged = UMX.untag file @@ -660,7 +804,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar Lines = NamedText(file, change) Version = None } - (file, new CancellationTokenSource()) |> Some + Some file else None with e -> @@ -673,42 +817,56 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar None) |> Result.ofOption (fun () -> $"Could not read file: {file}") - let forceFindOpenFile filePath = - findFileInOpenFiles filePath |> AVal.force |> Option.map fst + do FSharp.Compiler.IO.FileSystemAutoOpens.FileSystem <- FileSystem(FSharp.Compiler.IO.FileSystemAutoOpens.FileSystem, forceFindOpenFile) let forceFindSourceText filePath = - forceFindOpenFileOrRead filePath |> Result.map (fun (f, _) -> f.Lines) + forceFindOpenFileOrRead filePath |> Result.map (fun f -> f.Lines) - let openFilesToProjectOptions = - openFilesA - |> AMap.mapAdaptiveValue (fun (info, cts) -> - let file = info.Lines.FileName - if Utils.isAScript (UMX.untag file) then - (checker, tfmConfig) - ||> AVal.map2 (fun checker tfm -> - let opts = - checker.GetProjectOptionsFromScript(file, info.Lines, tfm) - |> Async.RunSynchronouslyWithCTSafe(fun () -> cts.Token) + let getProjectOptionsForFile' (filePath: string) file = + // TODO Optimize this for better performance + // typing #r "nuget: ... " seems to cause GetProjectOptionsFromScript getting called often + // which I suspect is also calling dotnet restore too many times + // Cancelling doesn't seem to be working as intended here. + aval { + if Utils.isAScript (UMX.untag filePath) then + let! checker = checker + and! tfmConfig = tfmConfig + and! cts = openFilesTokens |> AMap.tryFindA filePath + + return + option { + let (info: VolatileFile) = file + let! cts = cts - opts |> Option.iter (scriptFileProjectOptions.Trigger) - opts |> Option.map List.singleton |> Option.defaultValue List.empty) + let! opts = + checker.GetProjectOptionsFromScript(filePath, info.Lines, tfmConfig) + |> Async.RunSynchronouslyWithCTSafe(fun () -> cts.Token) + opts |> scriptFileProjectOptions.Trigger + return opts + } + |> Option.toList else - loadedProjectOptions - |> AVal.map (fun opts -> + let! opts = loadedProjectOptions + + return opts - |> List.filter (fun (opts) -> opts.SourceFiles |> Array.map Utils.normalizePath |> Array.contains (file)))) + |> List.filter (fun (opts) -> opts.SourceFiles |> Array.map Utils.normalizePath |> Array.contains (filePath)) + } + let openFilesToProjectOptions = + openFilesWithChanges + |> AMap.mapAVal (fun name file -> getProjectOptionsForFile' name file) - let getProjectOptionsForFile file = + let getProjectOptionsForFile (filePath: string) = openFilesToProjectOptions - |> AMap.tryFind file - |> AVal.bind (Option.defaultValue (AVal.constant [])) + |> AMap.tryFindA filePath + |> AVal.map (Option.defaultValue []) let autoCompleteItems: cmap * (Position -> option) * FSharp.Compiler.Syntax.ParsedInput> = cmap () @@ -728,10 +886,12 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let checkUnusedOpens = async { try + let! ct = Async.CancellationToken + let! unused = UnusedOpens.getUnusedOpens (tyRes.GetCheckResults, (fun i -> (source: ISourceText).GetLineString(i - 1))) - notifications.Trigger(NotificationEvent.UnusedOpens(filePath, (unused |> List.toArray))) + notifications.Trigger(NotificationEvent.UnusedOpens(filePath, (unused |> List.toArray)), ct) with e -> logger.error (Log.setMessage "checkUnusedOpens failed" >> Log.addExn e) } @@ -739,11 +899,12 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let checkUnusedDeclarations = async { try + let! ct = Async.CancellationToken let isScript = Utils.isAScript (UMX.untag filePath) let! unused = UnusedDeclarations.getUnusedDeclarations (tyRes.GetCheckResults, isScript) let unused = unused |> Seq.toArray - notifications.Trigger(NotificationEvent.UnusedDeclarations(filePath, unused)) + notifications.Trigger(NotificationEvent.UnusedDeclarations(filePath, unused), ct) with e -> logger.error (Log.setMessage "checkUnusedDeclarations failed" >> Log.addExn e) } @@ -753,9 +914,10 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar try let getSourceLine lineNo = source.GetLineString(lineNo - 1) + let! ct = Async.CancellationToken let! simplified = SimplifyNames.getSimplifiableNames (tyRes.GetCheckResults, getSourceLine) let simplified = Array.ofSeq simplified - notifications.Trigger(NotificationEvent.SimplifyNames(filePath, simplified)) + notifications.Trigger(NotificationEvent.SimplifyNames(filePath, simplified), ct) with e -> logger.error (Log.setMessage "checkSimplifiedNames failed" >> Log.addExn e) } @@ -781,88 +943,132 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar Version = version } } } + + let semaphore = new SemaphoreSlim(1, 1) + let parseAndCheckFile (checker: FSharpCompilerServiceChecker) (file: VolatileFile) opts config = async { - logger.info ( - Log.setMessage "Getting typecheck results for {file} - {hash} - {date}" - >> Log.addContextDestructured "file" file.Lines.FileName - >> Log.addContextDestructured "hash" (file.Lines.GetHashCode()) - >> Log.addContextDestructured "date" (file.Touched) - ) + try + logger.info ( + Log.setMessage "Getting typecheck results for {file} - {hash} - {date}" + >> Log.addContextDestructured "file" file.Lines.FileName + >> Log.addContextDestructured "hash" (file.Lines.GetHashCode()) + >> Log.addContextDestructured "date" (file.Touched) + ) - use cts = new CancellationTokenSource() - cts.CancelAfter(TimeSpan.FromSeconds(60.)) + let! ct = Async.CancellationToken + do! semaphore.WaitAsync(ct) |> Async.AwaitTask - let! result = - checker.ParseAndCheckFileInProject(file.Lines.FileName, (file.Lines.GetHashCode()), file.Lines, opts) - |> Async.withCancellation cts.Token + use _ = new ProgressListener(lspClient) + use progressReport = new ServerProgressReport(lspClient) - notifications.Trigger(NotificationEvent.FileParsed(file.Lines.FileName)) + let simpleName = Path.GetFileName(UMX.untag file.Lines.FileName) + do! progressReport.Begin($"Typechecking {simpleName}", message = $"{file.Lines.FileName}") - match result with - | Error e -> - logger.info ( - Log.setMessage "Typecheck failed for {file} with {error}" - >> Log.addContextDestructured "file" file - >> Log.addContextDestructured "error" e - ) - return failwith e - | Ok parseAndCheck -> - logger.info ( - Log.setMessage "Typecheck completed successfully for {file}" - >> Log.addContextDestructured "file" file.Lines.FileName - ) + // HACK: Insurance for a bug where FCS invalidates graph nodes incorrectly and seems to typecheck forever + use cts = new CancellationTokenSource() + cts.CancelAfter(TimeSpan.FromSeconds(60.)) + + let! result = + checker.ParseAndCheckFileInProject(file.Lines.FileName, (file.Lines.GetHashCode()), file.Lines, opts) + |> Async.withCancellation cts.Token + |> Debug.measureAsync $"checker.ParseAndCheckFileInProject - {file.Lines.FileName}" + do! progressReport.End($"Typechecked {file.Lines.FileName}") - let checkErrors = parseAndCheck.GetParseResults.Diagnostics - let parseErrors = parseAndCheck.GetCheckResults.Diagnostics + notifications.Trigger(NotificationEvent.FileParsed(file.Lines.FileName), ct) - let errors = - Array.append checkErrors parseErrors - |> Array.distinctBy (fun e -> - e.Severity, e.ErrorNumber, e.StartLine, e.StartColumn, e.EndLine, e.EndColumn, e.Message) + match result with + | Error e -> + logger.info ( + Log.setMessage "Typecheck failed for {file} with {error}" + >> Log.addContextDestructured "file" file + >> Log.addContextDestructured "error" e + ) - NotificationEvent.ParseError(errors, file.Lines.FileName) - |> notifications.Trigger + return failwith e + | Ok parseAndCheck -> + logger.info ( + Log.setMessage "Typecheck completed successfully for {file}" + >> Log.addContextDestructured "file" file.Lines.FileName + ) + Async.Start( + async { + let checkErrors = parseAndCheck.GetParseResults.Diagnostics + let parseErrors = parseAndCheck.GetCheckResults.Diagnostics - do! analyzeFile config (file.Lines.FileName, file.Version, file.Lines, parseAndCheck) + let errors = + Array.append checkErrors parseErrors + |> Array.distinctBy (fun e -> + e.Severity, e.ErrorNumber, e.StartLine, e.StartColumn, e.EndLine, e.EndColumn, e.Message) - // LargeObjectHeap gets fragmented easily for really large files, which F# can easily have. - // Yes this seems excessive doing this every time we type check but it's the best current kludge. - System.Runtime.GCSettings.LargeObjectHeapCompactionMode <- - System.Runtime.GCLargeObjectHeapCompactionMode.CompactOnce + notifications.Trigger(NotificationEvent.ParseError(errors, file.Lines.FileName), ct) + }, + ct + ) - GC.Collect() - GC.WaitForPendingFinalizers() + Async.Start(analyzeFile config (file.Lines.FileName, file.Version, file.Lines, parseAndCheck), ct) - return parseAndCheck + return parseAndCheck + finally + try + semaphore.Release() |> ignore + with :? SemaphoreFullException -> + () } + + let typeCheckerTokens = + new System.Collections.Concurrent.ConcurrentDictionary, CancellationTokenSource>() + + let getCTForFile filePath = + let add x = new CancellationTokenSource() + + let update x (typeCheckerToken: CancellationTokenSource) = + typeCheckerToken.Cancel() + new CancellationTokenSource() + + typeCheckerTokens.AddOrUpdate(filePath, add, update).Token + + let cancelCTForFile filePath = getCTForFile filePath |> ignore + /// Bypass Adaptive checking and tell the checker to check a file - let forceTypeCheck f = + let forceTypeCheck f opts = async { - logger.info (Log.setMessage "Forced Check : {file}" >> Log.addContextDestructured "file" f) - let checker = checker |> AVal.force - let config = config |> AVal.force + try + logger.info (Log.setMessage "Forced Check : {file}" >> Log.addContextDestructured "file" f) + let checker = checker |> AVal.force + let config = config |> AVal.force + + let opts = + opts + |> Option.orElseWith (fun () -> getProjectOptionsForFile f |> AVal.force |> Seq.tryHead) - match findFileInOpenFiles f |> AVal.force, getProjectOptionsForFile f |> AVal.force |> List.tryHead with - | Some (fileInfo, _), Some (opts) -> return! parseAndCheckFile checker fileInfo opts config |> Async.Ignore - | _, _ -> () + match forceFindOpenFileOrRead f, opts with + | Ok (fileInfo), Some opts -> return! parseAndCheckFile checker fileInfo opts config |> Async.Ignore + | _, _ -> () + with e -> + + logger.warn ( + Log.setMessage "Forced Check error : {file}" + >> Log.addContextDestructured "file" f + >> Log.addExn e + ) } let openFilesToParsedResults = - openFilesA - |> AMap.mapAdaptiveValue (fun (info, cts) -> + openFilesWithChanges + |> AMap.mapAVal (fun _ (info) -> aval { let file = info.Lines.FileName - let! checker = checker and! projectOptions = getProjectOptionsForFile file + and! cts = openFilesTokens |> AMap.tryFindA file - match List.tryHead projectOptions with - | Some opts -> + match List.tryHead projectOptions, cts with + | Some opts, Some cts -> return Debug.measure "parseFile" <| fun () -> @@ -870,13 +1076,13 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar checker.ParseFile(file, info.Lines, opts) |> Async.RunSynchronouslyWithCTSafe(fun () -> cts.Token) - | None -> return None + | _ -> return None }) let openFilesToRecentCheckedFilesResults = - openFilesA - |> AMap.mapAdaptiveValue (fun (info, _) -> + openFilesWithChanges + |> AMap.mapAVal (fun _ (info) -> aval { let file = info.Lines.FileName let! checker = checker @@ -887,28 +1093,29 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let parseAndCheck = checker.TryGetRecentCheckResultsForFile(file, opts, info.Lines) return parseAndCheck - | None -> return None + | _ -> return None }) let openFilesToCheckedFilesResults = - openFilesA - |> AMap.mapAdaptiveValue (fun (info, cts) -> + openFilesWithChanges + |> AMap.mapAVal (fun _ (info) -> aval { let file = info.Lines.FileName let! checker = checker and! projectOptions = getProjectOptionsForFile file and! config = config + and! cts = openFilesTokens |> AMap.tryFindA file - match List.tryHead projectOptions with - | Some (opts) -> + match List.tryHead projectOptions, cts with + | Some (opts), Some cts -> let parseAndCheck = - Debug.measure "parseAndCheckFile" + Debug.measure $"parseAndCheckFile - {file}" <| fun () -> parseAndCheckFile checker info opts config |> Async.RunSynchronouslyWithCTSafe(fun () -> cts.Token) return parseAndCheck - | None -> return None + | _ -> return None }) let getParseResults filePath = @@ -930,23 +1137,34 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar |> Result.ofOption (fun () -> $"No parse results for {filePath}") let forceGetTypeCheckResults filePath = - let tyResults = getTypeCheckResults (filePath) + getTypeCheckResults (filePath) + |> AVal.force + |> Result.ofOption (fun () -> $"No typecheck results for {filePath}") - match getRecentTypeCheckResults filePath |> AVal.force with - | Some s -> - if lock tyResults (fun () -> tyResults.OutOfDate) then - Async.Start(async { tyResults |> AVal.force |> ignore }) - Some s - | None -> tyResults |> AVal.force - |> Result.ofOption (fun () -> $"No typecheck results for {filePath}") + let forceGetTypeCheckResultsStale filePath = + aval { + let! checker = checker + + match checker.TryGetLastCheckResultForFile(filePath) with + | Some s -> return Ok s + | None -> return forceGetTypeCheckResults filePath + } + |> AVal.force - let openFilesToCheckedDeclarations = + + let openFilesToCheckedDeclarations () = openFilesToCheckedFilesResults - |> AMap.map' (AVal.mapOption (fun parseAndCheck -> parseAndCheck.GetParseResults.GetNavigationItems().Declarations)) + |> AMap.force + |> HashMap.map (fun _ v -> + v + |> AVal.mapOption (fun c -> c.GetParseResults.GetNavigationItems().Declarations) + |> AVal.force) let getDeclarations filename = - openFilesToCheckedDeclarations |> AMap.tryFindAndFlatten (filename) + openFilesToCheckedFilesResults + |> AMap.tryFindAndFlatten filename + |> AVal.mapOption (fun c -> c.GetParseResults.GetNavigationItems().Declarations) let getFilePathAndPosition (p: ITextDocumentPositionParams) = let filePath = p.GetFilePath() |> Utils.normalizePath @@ -963,7 +1181,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar { new ICodeGenerationService with member x.TokenizeLine(file, i) = option { - let! (text, _) = forceFindOpenFileOrRead file |> Option.ofResult + let! (text) = forceFindOpenFileOrRead file |> Option.ofResult try let! line = text.Lines.GetLine(Position.mkPos i 0) @@ -975,7 +1193,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar member x.GetSymbolAtPosition(file, pos) = option { try - let! (text, _) = forceFindOpenFileOrRead file |> Option.ofResult + let! (text) = forceFindOpenFileOrRead file |> Option.ofResult let! line = tryGetLineStr pos text.Lines |> Option.ofResult return! Lexer.getSymbol pos.Line pos.Column line SymbolLookupKind.Fuzzy [||] with _ -> @@ -983,14 +1201,14 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar } member x.GetSymbolAndUseAtPositionOfKind(fileName, pos, kind) = - asyncMaybe { + asyncOption { let! symbol = x.GetSymbolAtPosition(fileName, pos) if symbol.Kind = kind then - let! (text, _) = forceFindOpenFileOrRead fileName |> Option.ofResult + let! (text) = forceFindOpenFileOrRead fileName |> Option.ofResult let! line = tryGetLineStr pos text.Lines |> Option.ofResult - let! result = forceGetTypeCheckResults fileName |> Option.ofResult - let symbolUse = result.TryGetSymbolUse pos line + let! tyRes = forceGetTypeCheckResults fileName |> Option.ofResult + let symbolUse = tyRes.TryGetSymbolUse pos line return! Some(symbol, symbolUse) else return! None @@ -1004,9 +1222,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let tryGetParseResultsForFile filePath pos = asyncResult { - let! (file, _) = forceFindOpenFileOrRead filePath + let! (file) = forceFindOpenFileOrRead filePath let! lineStr = file.Lines |> tryGetLineStr pos - let! tyRes = forceGetTypeCheckResults filePath + and! tyRes = forceGetTypeCheckResults filePath return tyRes, lineStr, file.Lines } @@ -1051,7 +1269,6 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let writeAbstractClassStub = AbstractClassStubGenerator.writeAbstractClassStub codeGenServer - let foo bar fizz = fizz * fizz let getAbstractClassStub tyRes objExprRange lines lineStr = Commands.getAbstractClassStub @@ -1160,6 +1377,10 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar false)) |> AVal.force + transact (fun () -> + openFiles.Remove filePath |> ignore + openFilesTokens.Remove filePath |> ignore + textChanges.Remove filePath |> ignore) if doesNotExist filePath || isOutsideWorkspace filePath then logger.info ( @@ -1167,7 +1388,6 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar >> Log.addContext "file" filePath ) - transact (fun () -> openFiles.Remove filePath |> ignore) diagnosticCollections.ClearFor(uri) else logger.info ( @@ -1175,6 +1395,122 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar >> Log.addContext "file" filePath ) + let getDependentFilesForFile file = + let projects = getProjectOptionsForFile file |> AVal.force + + projects + |> List.toArray + |> Array.collect (fun proj -> + logger.info ( + Log.setMessage "Source Files: {sourceFiles}" + >> Log.addContextDestructured "sourceFiles" proj.SourceFiles + ) + + let idx = proj.SourceFiles |> Array.findIndex (fun x -> x = UMX.untag file) + + proj.SourceFiles + |> Array.splitAt idx + |> snd + |> Array.map (fun sourceFile -> proj, sourceFile)) + |> Array.distinct + + let getDependentProjectsOfProjects ps = + let projectSnapshot = loadedProjectOptions |> AVal.force + + let allDependents = System.Collections.Generic.HashSet() + + let currentPass = ResizeArray() + currentPass.AddRange(ps |> List.map (fun p -> p.ProjectFileName)) + + let mutable continueAlong = true + + while continueAlong do + let dependents = + projectSnapshot + |> Seq.filter (fun p -> + p.ReferencedProjects + |> Seq.exists (fun r -> + match r.ProjectFilePath with + | None -> false + | Some p -> currentPass.Contains(p))) + + if Seq.isEmpty dependents then + continueAlong <- false + currentPass.Clear() + else + for d in dependents do + allDependents.Add d |> ignore + + currentPass.Clear() + currentPass.AddRange(dependents |> Seq.map (fun p -> p.ProjectFileName)) + + Seq.toList allDependents + + let forceCheckDepenenciesForFile filePath = + async { + let dependentFiles = getDependentFilesForFile filePath + + let dependentProjects = + getProjectOptionsForFile filePath + |> AVal.force + |> getDependentProjectsOfProjects + |> List.toArray + |> Array.collect (fun proj -> proj.SourceFiles |> Array.map (fun sourceFile -> proj, sourceFile)) + + + let mutable checksCompleted = 0 + + + let progressToken = ProgressToken.Second(Guid.NewGuid().ToString()) + do! lspClient.WorkDoneProgressCreate progressToken |> Async.Ignore + use progressReporter = new ServerProgressReport(lspClient) + + + let percentage numerator denominator = + if denominator = 0 then + 0u + else + ((float numerator) / (float denominator)) * 100.0 |> uint32 + + + let checksToPerform = + let innerChecks = + Array.concat [| dependentFiles; dependentProjects |] + |> Array.filter (fun (_, file) -> file.Contains "AssemblyInfo.fs" |> not) + + let checksToPerformLength = innerChecks.Length + + innerChecks + |> Array.map (fun (proj, file) -> + let file = UMX.tag file + let token = getCTForFile file + + + forceTypeCheck (file) (Some proj) + |> Async.withCancellationSafe (fun () -> token) + |> Async.Ignore + |> Async.bind (fun _ -> + async { + Interlocked.Increment(&checksCompleted) |> ignore + + do! + progressReporter.Report( + message = $"{checksCompleted}/{checksToPerformLength} remaining", + percentage = percentage checksCompleted checksToPerformLength + ) + })) + + + do! + progressReporter.Begin( + "Typechecking Dependent F# files", + message = $"0/{checksToPerform.Length} remaining", + percentage = percentage 0 checksToPerform.Length + ) + + do! Async.Parallel(checksToPerform, 2) |> Async.Ignore + + } let symbolUseWorkspace pos lineStr text tyRes = @@ -1193,37 +1529,6 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar |> AVal.force |> Seq.tryFind (fun x -> x.ProjectFileName = file) - let getDependentProjectsOfProjects ps = - let projectSnapshot = loadedProjectOptions |> AVal.force - - let allDependents = System.Collections.Generic.HashSet() - - let currentPass = ResizeArray() - currentPass.AddRange(ps |> List.map (fun p -> p.ProjectFileName)) - - let mutable continueAlong = true - - while continueAlong do - let dependents = - projectSnapshot - |> Seq.filter (fun p -> - p.ReferencedProjects - |> Seq.exists (fun r -> - match r.ProjectFilePath with - | None -> false - | Some p -> currentPass.Contains(p))) - - if Seq.isEmpty dependents then - continueAlong <- false - currentPass.Clear() - else - for d in dependents do - allDependents.Add d |> ignore - - currentPass.Clear() - currentPass.AddRange(dependents |> Seq.map (fun p -> p.ProjectFileName)) - - Seq.toList allDependents let getDeclarationLocation (symUse, text) = SymbolLocation.getDeclarationLocation ( @@ -1459,55 +1764,17 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar transact (fun () -> rootPath.Value <- actualRootPath clientCapabilities.Value <- p.Capabilities + lspClient.ClientCapabilities <- p.Capabilities updateConfig c workspacePaths.Value <- WorkspaceChosen.Projs(HashSet.ofList projs)) + let defaultSettings = + { Helpers.defaultServerCapabilities with + TextDocumentSync = + Helpers.defaultServerCapabilities.TextDocumentSync + |> Option.map (fun x -> { x with Change = Some TextDocumentSyncKind.Incremental }) } - return - { InitializeResult.Default with - Capabilities = - { ServerCapabilities.Default with - HoverProvider = Some true - RenameProvider = Some(U2.First true) - DefinitionProvider = Some true - TypeDefinitionProvider = Some true - ImplementationProvider = Some true - ReferencesProvider = Some true - DocumentHighlightProvider = Some true - DocumentSymbolProvider = Some true - WorkspaceSymbolProvider = Some true - DocumentFormattingProvider = Some true - DocumentRangeFormattingProvider = Some true - SignatureHelpProvider = - Some - { TriggerCharacters = Some [| '('; ','; ' ' |] - RetriggerCharacters = Some [| ','; ')'; ' ' |] } - CompletionProvider = - Some - { ResolveProvider = Some true - TriggerCharacters = Some([| '.'; ''' |]) - AllCommitCharacters = None //TODO: what chars shoudl commit completions? - } - CodeLensProvider = Some { CodeLensOptions.ResolveProvider = Some true } - CodeActionProvider = - Some - { CodeActionKinds = None - ResolveProvider = None } - TextDocumentSync = - Some - { TextDocumentSyncOptions.Default with - OpenClose = Some true - Change = Some TextDocumentSyncKind.Full - Save = Some { IncludeText = Some true } } - FoldingRangeProvider = Some true - SelectionRangeProvider = Some true - SemanticTokensProvider = - Some - { Legend = - createTokenLegend - Range = Some true - Full = Some(U2.First true) } - InlayHintProvider = Some { ResolveProvider = Some false } } } + return { InitializeResult.Default with Capabilities = defaultSettings } with e -> logger.error ( @@ -1547,11 +1814,15 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let doc = p.TextDocument let filePath = doc.GetFilePath() |> Utils.normalizePath - // We want to try to use the file system's datetime if available - let file = VolatileFile.Create(filePath, doc.Text, (Some doc.Version)) - updateOpenFiles file - forceGetTypeCheckResults filePath |> ignore - return () + + if isFileOpen filePath |> AVal.force then + return () + else + // We want to try to use the file system's datetime if available + let file = VolatileFile.Create(filePath, doc.Text, (Some doc.Version)) + updateOpenFiles file + forceGetTypeCheckResults filePath |> ignore + return () with e -> logger.error ( Log.setMessage "TextDocumentDidOpen Request Errored {p}" @@ -1592,17 +1863,24 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar >> Log.addContextDestructured "parms" p ) - let filePath = p.TextDocument.GetFilePath() |> Utils.normalizePath - let changes = p.ContentChanges |> Array.head + let doc = p.TextDocument + let filePath = doc.GetFilePath() |> Utils.normalizePath + resetAllCancellationTokens () + cancelCTForFile filePath - // We want to update the DateTime here since TextDocumentDidChange will not have changes reflected on disk - // TODO: Incremental changes - let file = - VolatileFile.Create(filePath, changes.Text, p.TextDocument.Version, DateTime.UtcNow) + updateTextchanges filePath (p, DateTime.UtcNow) - updateOpenFiles file - forceGetTypeCheckResults filePath |> ignore + async { + do! Async.Sleep(10) + forceGetTypeCheckResults filePath |> ignore + + //! for smaller projects this isn't really an issue type checking all dependants but bigger ones it is + //? Should we have a setting to enable/disable this? + // do! forceCheckDepenenciesForFile filePath + + } + |> Async.Start return () with e -> @@ -1613,7 +1891,6 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) return () - } override __.TextDocumentDidSave(p) = @@ -1624,6 +1901,8 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar >> Log.addContextDestructured "parms" p ) + resetAllCancellationTokens () + let doc = p.TextDocument let filePath = doc.GetFilePath() |> Utils.normalizePath @@ -1637,25 +1916,18 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar // Very unlikely to get here VolatileFile.Create(filePath, p.Text.Value, None, DateTime.UtcNow)) - updateOpenFiles file - let knownFiles = openFilesA |> AMap.force - - logger.info ( - Log.setMessage "typechecking for files {files}" - >> Log.addContextDestructured "files" knownFiles - ) - - cancelAllOpenFileCheckRequests () - - for (file, aFile) in knownFiles do - let (_, cts) = aFile |> AVal.force + transact (fun () -> + updateOpenFiles file + textChanges.Remove filePath |> ignore) - do! - forceTypeCheck file - |> Async.withCancellationSafe (fun () -> cts.Token) - |> Async.Ignore + async { + do! Async.Sleep(10) + forceGetTypeCheckResults filePath |> ignore + do! forceCheckDepenenciesForFile filePath + do! lspClient.CodeLensRefresh() - do! lspClient.CodeLensRefresh() + } + |> Async.Start return () with e -> @@ -1679,19 +1951,16 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText2) = forceFindOpenFileOrRead filePath |> Result.ofStringErr - let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - - let completionList = - { IsIncomplete = false - Items = KeywordList.hashSymbolCompletionItems } + let! lineStr2 = namedText2.Lines |> tryGetLineStr pos |> Result.ofStringErr - if lineStr.StartsWith "#" then + if lineStr2.StartsWith "#" then let completionList = { IsIncomplete = false Items = KeywordList.hashSymbolCompletionItems } + return! success (Some completionList) else let config = AVal.force config @@ -1708,29 +1977,41 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let getCompletions = asyncResult { - let! typeCheckResults = forceGetTypeCheckResults filePath + + let! (namedText) = forceFindOpenFileOrRead filePath + let! lineStr = namedText.Lines |> tryGetLineStr pos + and! typeCheckResults = forceGetTypeCheckResultsStale filePath let getAllSymbols () = if config.ExternalAutocomplete then typeCheckResults.GetAllEntities true else [] - - match! + // TextDocumentCompletion will sometimes come in before TextDocumentDidChange + // This will require the trigger character to be at the place VSCode says it is + // Otherwise we'll fail here and our retry logic will come into place + do! + match p.Context with + | Some ({ triggerKind = CompletionTriggerKind.TriggerCharacter } as context) -> + namedText.Lines.TryGetChar pos = context.triggerCharacter + | _ -> true + |> Result.requireTrue $"TextDocumentCompletion was sent before TextDocumentDidChange" + + + let! (decls, residue, shouldKeywords) = Debug.measure "TextDocumentCompletion.TryGetCompletions" (fun () -> - typeCheckResults.TryGetCompletions pos lineStr None getAllSymbols) - with - | None -> return None - | Some (decls, residue, shouldKeywords) -> - return Some(decls, residue, shouldKeywords, typeCheckResults, getAllSymbols) + typeCheckResults.TryGetCompletions pos lineStr None getAllSymbols + |> AsyncResult.ofOption (fun () -> "No TryGetCompletions results")) + + return Some(decls, residue, shouldKeywords, typeCheckResults, getAllSymbols, namedText) } match! - retryAsyncOption (TimeSpan.FromMilliseconds(100.)) 5 getCompletions + retryAsyncOption (TimeSpan.FromMilliseconds(10.)) 100 getCompletions |> AsyncResult.ofStringErr with - | None -> return! success (Some completionList) - | Some (decls, residue, shouldKeywords, typeCheckResults, getAllSymbols) -> + | None -> return! success (None) + | Some (decls, _, shouldKeywords, typeCheckResults, _, namedText) -> return! Debug.measure "TextDocumentCompletion.TryGetCompletions success" @@ -1834,7 +2115,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar else sym - let decls = openFilesToCheckedDeclarations |> AMap.force |> Seq.map (snd) + // let decls = openFilesToCheckedDeclarations |> AMap.force |> Seq.map (snd) match getAutoCompleteByDeclName sym |> AVal.force with | None -> //Isn't in sync filled cache, we don't have result @@ -1887,10 +2168,10 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + - let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let charAtCaret = p.Context |> Option.bind (fun c -> c.TriggerCharacter) @@ -1946,9 +2227,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResultsStale filePath |> Result.ofStringErr match tyRes.TryGetToolTipEnhanced pos lineStr with | Ok (Some (tip, signature, footer, typeDoc)) -> @@ -2022,9 +2303,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! documentsAndRanges = @@ -2048,7 +2329,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let version = forceFindOpenFileOrRead namedText.FileName |> Option.ofResult - |> Option.bind (fun (f, _) -> f.Version) + |> Option.bind (fun (f) -> f.Version) { TextDocument = { Uri = Path.FilePathToUri(UMX.untag namedText.FileName) @@ -2077,10 +2358,10 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! decl = tyRes.TryFindDeclaration pos lineStr |> AsyncResult.ofStringErr return decl |> findDeclToLspLocation |> GotoResult.Single |> Some with e -> @@ -2103,9 +2384,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! decl = tyRes.TryFindTypeDeclaration pos lineStr |> AsyncResult.ofStringErr return decl |> findDeclToLspLocation |> GotoResult.Single |> Some with e -> @@ -2127,9 +2408,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = tryGetLineStr pos namedText.Lines |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! usages = symbolUseWorkspace pos lineStr namedText.Lines tyRes @@ -2167,9 +2448,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = tryGetLineStr pos namedText.Lines |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! (symbol, uses) = tyRes.TryGetSymbolUseAndUsages pos lineStr |> Result.ofStringErr @@ -2199,9 +2480,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = tryGetLineStr pos namedText.Lines |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr logger.info ( Log.setMessage "TextDocumentImplementation Request: {parms}" @@ -2295,10 +2576,8 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let glyphToSymbolKind = glyphToSymbolKind |> AVal.force let decls = - openFilesToCheckedDeclarations - |> AMap.force + openFilesToCheckedDeclarations () |> Seq.toArray - |> Array.map (fun (p, ns) -> p, AVal.force ns) |> Array.choose (fun (p, ns) -> ns |> Option.map (fun ns -> p, ns)) let res = @@ -2446,7 +2725,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let tryGetFileVersion filePath = forceFindOpenFileOrRead filePath |> Option.ofResult - |> Option.bind (fun (f, _) -> f.Version) + |> Option.bind (fun (f) -> f.Version) let clientCapabilities = clientCapabilities |> AVal.force @@ -2716,7 +2995,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let getParseResultsForFile file = asyncResult { let! namedText = forceFindSourceText file - let! parseResults = forceGetParseResults file + and! parseResults = forceGetParseResults file return namedText, parseResults } @@ -2826,9 +3105,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let filePath = p.TextDocument.GetFilePath() |> Utils.normalizePath - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let fcsRange = protocolRangeToRange (UMX.untag filePath) p.Range let config = config |> AVal.force @@ -3096,10 +3375,10 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! tip = Commands.typesig tyRes pos lineStr |> Result.ofCoreResponse return { Content = CommandResponse.typeSig FsAutoComplete.JsonSerializer.writeJson tip } @@ -3125,10 +3404,10 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar FSharp.Compiler.Text.Position.mkPos (p.Position.Line) (p.Position.Character + 2) let filePath = p.TextDocument.GetFilePath() |> Utils.normalizePath - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! (typ, parms, generics) = tyRes.TryGetSignatureData pos lineStr |> Result.ofStringErr return @@ -3154,10 +3433,10 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! { InsertPosition = insertPos InsertText = text } = @@ -3175,7 +3454,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar NewText = text } |] } |] Changes = None } } - let! response = lspClient.WorkspaceApplyEdit edit + let! _ = lspClient.WorkspaceApplyEdit edit return () with e -> @@ -3468,9 +3747,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr let! t = Commands.Help tyRes pos lineStr |> Result.ofCoreResponse return { Content = CommandResponse.help FsAutoComplete.JsonSerializer.writeJson t } with e -> @@ -3492,9 +3771,9 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar ) let (filePath, pos) = getFilePathAndPosition p - let! (namedText, _) = forceFindOpenFileOrRead filePath |> Result.ofStringErr + let! (namedText) = forceFindOpenFileOrRead filePath |> Result.ofStringErr let! lineStr = namedText.Lines |> tryGetLineStr pos |> Result.ofStringErr - let! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr + and! tyRes = forceGetTypeCheckResults filePath |> Result.ofStringErr lastFSharpDocumentationTypeCheck <- Some tyRes let! t = Commands.FormattedDocumentation tyRes pos lineStr |> Result.ofCoreResponse return { Content = CommandResponse.formattedDocumentation FsAutoComplete.JsonSerializer.writeJson t } @@ -3751,6 +4030,16 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar override x.Dispose() = disposables.Dispose() + member this.WorkDoneProgessCancel(token: ProgressToken) : Async = + async { + logger.info ( + Log.setMessage "WorkDoneProgessCancel Request: {parms}" + >> Log.addContextDestructured "parms" token + ) + + return () + } + module AdaptiveFSharpLspServer = open System.Threading.Tasks diff --git a/src/FsAutoComplete/LspServers/Common.fs b/src/FsAutoComplete/LspServers/Common.fs index 24d40c351..7e9ba4ac6 100644 --- a/src/FsAutoComplete/LspServers/Common.fs +++ b/src/FsAutoComplete/LspServers/Common.fs @@ -137,8 +137,15 @@ type DiagnosticCollection(sendDiagnostics: DocumentUri -> Diagnostic[] -> Async< cts.Cancel() module Async = + open FsAutoComplete.Logging + open FsAutoComplete.Logging.Types open System.Threading.Tasks + let rec logger = LogProvider.getLoggerByQuotation <@ logger @> + + let inline logCancelled e = + logger.trace (Log.setMessage "Operation Cancelled" >> Log.addExn e) + let withCancellation (ct: CancellationToken) (a: Async<'a>) : Async<'a> = async { let! ct2 = Async.CancellationToken @@ -165,11 +172,16 @@ module Async = let! result = withCancellation (ct ()) work return Some result with - | :? OperationCanceledException as e -> return None + | :? OperationCanceledException as e -> + logCancelled e + return None | :? ObjectDisposedException as e when e.Message.Contains("CancellationTokenSource has been disposed") -> + logCancelled e return None } + let StartWithCT ct work = Async.Start(work, ct) + let RunSynchronouslyWithCT ct work = Async.RunSynchronously(work, cancellationToken = ct) @@ -177,8 +189,12 @@ module Async = try work |> RunSynchronouslyWithCT(ct ()) |> Some with - | :? OperationCanceledException as e -> None - | :? ObjectDisposedException as e when e.Message.Contains("CancellationTokenSource has been disposed") -> None + | :? OperationCanceledException as e -> + logCancelled e + None + | :? ObjectDisposedException as e when e.Message.Contains("CancellationTokenSource has been disposed") -> + logCancelled e + None [] module ObservableExtensions = @@ -197,3 +213,47 @@ module Helpers = let ignoreNotification = async.Return(()) let fullPathNormalized = Path.GetFullPath >> Utils.normalizePath >> UMX.untag + + let defaultServerCapabilities = + { ServerCapabilities.Default with + HoverProvider = Some true + RenameProvider = Some(U2.First true) + DefinitionProvider = Some true + TypeDefinitionProvider = Some true + ImplementationProvider = Some true + ReferencesProvider = Some true + DocumentHighlightProvider = Some true + DocumentSymbolProvider = Some true + WorkspaceSymbolProvider = Some true + DocumentFormattingProvider = Some true + DocumentRangeFormattingProvider = Some true + SignatureHelpProvider = + Some + { TriggerCharacters = Some [| '('; ','; ' ' |] + RetriggerCharacters = Some [| ','; ')'; ' ' |] } + CompletionProvider = + Some + { ResolveProvider = Some true + TriggerCharacters = Some([| '.'; ''' |]) + AllCommitCharacters = None //TODO: what chars shoudl commit completions? + } + CodeLensProvider = Some { CodeLensOptions.ResolveProvider = Some true } + CodeActionProvider = + Some + { CodeActionKinds = None + ResolveProvider = None } + TextDocumentSync = + Some + { TextDocumentSyncOptions.Default with + OpenClose = Some true + Change = Some TextDocumentSyncKind.Incremental + Save = Some { IncludeText = Some true } } + FoldingRangeProvider = Some true + SelectionRangeProvider = Some true + SemanticTokensProvider = + Some + { Legend = + createTokenLegend + Range = Some true + Full = Some(U2.First true) } + InlayHintProvider = Some { ResolveProvider = Some false } } diff --git a/src/FsAutoComplete/LspServers/FSharpLspClient.fs b/src/FsAutoComplete/LspServers/FSharpLspClient.fs index d5ac778bf..f70e54625 100644 --- a/src/FsAutoComplete/LspServers/FSharpLspClient.fs +++ b/src/FsAutoComplete/LspServers/FSharpLspClient.fs @@ -6,6 +6,9 @@ open Ionide.LanguageServerProtocol.Types.LspResult open Ionide.LanguageServerProtocol.Server open Ionide.LanguageServerProtocol.Types open FsAutoComplete.LspHelpers +open System +open System.Threading.Tasks + type FSharpLspClient(sendServerNotification: ClientNotificationSender, sendServerRequest: ClientRequestSender) = @@ -71,3 +74,133 @@ type FSharpLspClient(sendServerNotification: ClientNotificationSender, sendServe | Some { Workspace = Some { CodeLens = Some { RefreshSupport = Some true } } } -> sendServerNotification "workspace/codeLens/refresh" () |> Async.Ignore | _ -> async { return () } + + override x.WorkDoneProgressCreate(token) = + match x.ClientCapabilities with + | Some { Window = Some { workDoneProgress = Some true } } -> + let progressCreate: WorkDoneProgressCreateParams = { token = token } + sendServerRequest.Send "window/workDoneProgress/create" (box progressCreate) + | _ -> async { return Error(JsonRpc.Error.InternalErrorMessage "workDoneProgress is disabled") } + + override x.Progress(token, value) = + let progress: ProgressParams<_> = { token = token; value = value } + sendServerNotification "$/progress" (box progress) |> Async.Ignore + + + +type ServerProgressReport(lspClient: FSharpLspClient, ?token: ProgressToken) = + + let mutable canReportProgress = true + let mutable endSent = false + + member val Token = defaultArg token (ProgressToken.Second((Guid.NewGuid().ToString()))) + + member x.Begin(title, ?cancellable, ?message, ?percentage) = + async { + let! result = lspClient.WorkDoneProgressCreate x.Token + + match result with + | Ok () -> () + | Error e -> canReportProgress <- false + + if canReportProgress then + do! + lspClient.Progress( + x.Token, + WorkDoneProgressBegin.Create( + title, + ?cancellable = cancellable, + ?message = message, + ?percentage = percentage + ) + ) + } + + member x.Report(?cancellable, ?message, ?percentage) = + async { + if canReportProgress then + do! + lspClient.Progress( + x.Token, + WorkDoneProgressReport.Create(?cancellable = cancellable, ?message = message, ?percentage = percentage) + ) + } + + member x.End(?message) = + async { + if canReportProgress && not endSent then + do! lspClient.Progress(x.Token, WorkDoneProgressEnd.Create(?message = message)) + endSent <- true + } + + interface IAsyncDisposable with + member x.DisposeAsync() = task { do! x.End() } |> ValueTask + + interface IDisposable with + member x.Dispose() = + (x :> IAsyncDisposable).DisposeAsync().GetAwaiter().GetResult() + + +open System.Diagnostics.Tracing +open System.Collections.Concurrent + +/// listener for the the events generated by the `FSharp.Compiler.FSharpCompilerEventSource` +type ProgressListener(lspClient) = + inherit EventListener() + let locker = obj () + let mutable isDisposing = false + let dispose (d: #IDisposable) = d.Dispose() + let mutable source = null + + let mutable inflightEvents = ConcurrentDictionary<_, ServerProgressReport>() + + override __.OnEventSourceCreated newSource = + if newSource.Name = "FSharpCompiler" then + ``base``.EnableEvents(newSource, EventLevel.LogAlways, EventKeywords.All) + source <- newSource + + override __.OnEventWritten eventArgs = + + lock locker + <| fun () -> + try + if isDisposing then + () + else + let message = + match eventArgs.EventId with + | 5 -> + let progressReport = new ServerProgressReport(lspClient) + let message = eventArgs.Payload.[0] |> string + let fileName = IO.Path.GetFileName message + + if inflightEvents.TryAdd(eventArgs.Task, progressReport) then + progressReport.Begin($"Dependent Typecheck {fileName}", message = message) + |> Async.Start + | 6 -> + let message = eventArgs.Payload.[0] |> string + + match inflightEvents.TryRemove(eventArgs.Task) with + | true, report -> + report.End($"Finished {message}") |> Async.Start + dispose report + () + | false, _ -> + + () + | other -> () + + message + with e -> + () + + member _.DisableEvents(source) = ``base``.DisableEvents(source) + + interface System.IDisposable with + member this.Dispose() = + lock locker + <| fun () -> + if isNull source then () else this.DisableEvents(source) + isDisposing <- true + inflightEvents.Values |> Seq.iter (dispose) + inflightEvents <- null diff --git a/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs b/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs index b00656566..beaaa0a8e 100644 --- a/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs +++ b/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs @@ -1243,50 +1243,7 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient) = |> Async.Start return - { InitializeResult.Default with - Capabilities = - { ServerCapabilities.Default with - HoverProvider = Some true - RenameProvider = Some(U2.First true) - DefinitionProvider = Some true - TypeDefinitionProvider = Some true - ImplementationProvider = Some true - ReferencesProvider = Some true - DocumentHighlightProvider = Some true - DocumentSymbolProvider = Some true - WorkspaceSymbolProvider = Some true - DocumentFormattingProvider = Some true - DocumentRangeFormattingProvider = Some true - SignatureHelpProvider = - Some - { TriggerCharacters = Some [| '('; ','; ' ' |] - RetriggerCharacters = Some [| ','; ')'; ' ' |] } - CompletionProvider = - Some - { ResolveProvider = Some true - TriggerCharacters = Some([| '.'; ''' |]) - AllCommitCharacters = None //TODO: what chars shoudl commit completions? - } - CodeLensProvider = Some { CodeLensOptions.ResolveProvider = Some true } - CodeActionProvider = - Some - { CodeActionKinds = None - ResolveProvider = None } - TextDocumentSync = - Some - { TextDocumentSyncOptions.Default with - OpenClose = Some true - Change = Some TextDocumentSyncKind.Full - Save = Some { IncludeText = Some true } } - FoldingRangeProvider = Some true - SelectionRangeProvider = Some true - SemanticTokensProvider = - Some - { Legend = - createTokenLegend - Range = Some true - Full = Some(U2.First true) } - InlayHintProvider = Some { ResolveProvider = Some false } } } + { InitializeResult.Default with Capabilities = Helpers.defaultServerCapabilities } |> success } @@ -2883,6 +2840,8 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient) = override x.Dispose() = (x :> ILspServer).Shutdown() |> Async.Start + member this.WorkDoneProgessCancel(arg1: ProgressToken) : Async = failwith "Not Implemented" + module FSharpLspServer = open System.Threading.Tasks diff --git a/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs b/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs index a3693571c..a7b347f64 100644 --- a/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs +++ b/test/FsAutoComplete.Tests.Lsp/CodeFixTests/Tests.fs @@ -1331,7 +1331,7 @@ let private renameUnusedValue state = """ (Diagnostics.acceptAll) selectPrefix - + testCaseAsync "replace doesn't trigger for function" <| CodeFix.checkNotApplicable server """ @@ -1370,8 +1370,8 @@ let private replaceWithSuggestionTests state = let selectCodeFix replacement = CodeFix.withTitle (ReplaceWithSuggestion.title replacement) let validateDiags (diags: Diagnostic[]) = Diagnostics.expectCode "39" diags - Expect.exists - diags + Expect.exists + diags (fun (d: Diagnostic) -> d.Message.Contains "Maybe you want one of the following:") "Diagnostic with code 39 should suggest name" testCaseAsync "can change Min to min" <| @@ -1467,19 +1467,74 @@ let private replaceWithSuggestionTests state = let private resolveNamespaceTests state = let config = { defaultConfigDto with ResolveNamespaces = Some true } serverTestList (nameof ResolveNamespace) state config None (fun server -> [ + let selectCodeFix = CodeFix.matching (fun ca -> ca.Title.StartsWith "open") testCaseAsync "doesn't fail when target not in last line" <| CodeFix.checkApplicable server """ let x = $0Min(2.0, 1.0) """ // Note: new line at end! (Diagnostics.log >> Diagnostics.acceptAll) - (CodeFix.log >> CodeFix.matching (fun ca -> ca.Title.StartsWith "open") >> Array.take 1) + (CodeFix.log >> selectCodeFix >> Array.take 1) testCaseAsync "doesn't fail when target in last line" <| CodeFix.checkApplicable server "let x = $0Min(2.0, 1.0)" // Note: No new line at end! (Diagnostics.log >> Diagnostics.acceptAll) - (CodeFix.log >> CodeFix.matching (fun ca -> ca.Title.StartsWith "open") >> Array.take 1) + (CodeFix.log >> selectCodeFix >> Array.take 1) + testCaseAsync "place open in module correctly when having additional modules" + <| CodeFix.check + server + """ +module Foo = + open Microsoft + + let foo = Date$0Time.Now + """ + (Diagnostics.log >> Diagnostics.acceptAll) + selectCodeFix + """ +module Foo = + open Microsoft + open System + + let foo = DateTime.Now + """ + + + testCaseAsync "place open in module correctly without any modules" + <| CodeFix.check + server + """ +module Foo = + let foo = $0DateTime.Now + """ + (Diagnostics.log >> Diagnostics.acceptAll) + selectCodeFix + """ +module Foo = + open System + let foo = DateTime.Now + """ + + + testCaseAsync "With attribute" + <| CodeFix.check + server + """ +[] +module Foo = + + let foo = $0DateTime.Now + """ + (Diagnostics.log >> Diagnostics.acceptAll) + selectCodeFix + """ +[] +module Foo = + open System + + let foo = DateTime.Now + """ //TODO: Implement & unify with `Completion.AutoOpen` (`CompletionTests.fs`) // Issues: // * Complex because of nesting modules (-> where to open) @@ -1579,7 +1634,7 @@ let private wrapExpressionInParenthesesTests state = selectCodeFix ]) -let tests state = testList "CodeFix tests" [ +let tests state = testList "CodeFix-tests" [ HelpersTests.tests AddExplicitTypeAnnotationTests.tests state diff --git a/test/FsAutoComplete.Tests.Lsp/CoreTests.fs b/test/FsAutoComplete.Tests.Lsp/CoreTests.fs index 26b6b7560..f345ed320 100644 --- a/test/FsAutoComplete.Tests.Lsp/CoreTests.fs +++ b/test/FsAutoComplete.Tests.Lsp/CoreTests.fs @@ -91,7 +91,7 @@ let initTests createServer = let td = { TextDocumentSyncOptions.Default with OpenClose = Some true - Change = Some TextDocumentSyncKind.Full + Change = Some TextDocumentSyncKind.Incremental Save = Some { IncludeText = Some true } } Expect.equal res.Capabilities.TextDocumentSync (Some td) "Text Document Provider" diff --git a/test/FsAutoComplete.Tests.Lsp/FsAutoComplete.Tests.Lsp.fsproj b/test/FsAutoComplete.Tests.Lsp/FsAutoComplete.Tests.Lsp.fsproj index 6b4a693ec..f031133ec 100644 --- a/test/FsAutoComplete.Tests.Lsp/FsAutoComplete.Tests.Lsp.fsproj +++ b/test/FsAutoComplete.Tests.Lsp/FsAutoComplete.Tests.Lsp.fsproj @@ -36,5 +36,11 @@ + + + + diff --git a/test/FsAutoComplete.Tests.Lsp/Helpers.fs b/test/FsAutoComplete.Tests.Lsp/Helpers.fs index 372254c65..b43cc630f 100644 --- a/test/FsAutoComplete.Tests.Lsp/Helpers.fs +++ b/test/FsAutoComplete.Tests.Lsp/Helpers.fs @@ -357,7 +357,8 @@ let clientCaps: ClientCapabilities = { Workspace = Some workspaceCaps TextDocument = Some textCaps - Experimental = None } + Experimental = None + Window = None } open Expecto.Logging open Expecto.Logging.Message diff --git a/test/FsAutoComplete.Tests.Lsp/Program.fs b/test/FsAutoComplete.Tests.Lsp/Program.fs index f05d78456..e65e01dc1 100644 --- a/test/FsAutoComplete.Tests.Lsp/Program.fs +++ b/test/FsAutoComplete.Tests.Lsp/Program.fs @@ -93,7 +93,8 @@ let lspTests = uriTests //linterTests createServer formattingTests createServer - analyzerTests createServer // stalling on adaptive + if lspName <> "AdaptiveLspServer" then + analyzerTests createServer // stalling on adaptive signatureTests createServer SignatureHelp.tests createServer CodeFixTests.Tests.tests createServer @@ -101,7 +102,8 @@ let lspTests = GoTo.tests createServer FindReferences.tests createServer InfoPanelTests.docFormattingTest createServer - DetectUnitTests.tests createServer //stalling on adaptive + if lspName <> "AdaptiveLspServer" then + DetectUnitTests.tests createServer //stalling on adaptive XmlDocumentationGeneration.tests createServer InlayHintTests.tests createServer DependentFileChecking.tests createServer diff --git a/test/FsAutoComplete.Tests.Lsp/Utils/TextEdit.fs b/test/FsAutoComplete.Tests.Lsp/Utils/TextEdit.fs index f0f3aed18..741503e39 100644 --- a/test/FsAutoComplete.Tests.Lsp/Utils/TextEdit.fs +++ b/test/FsAutoComplete.Tests.Lsp/Utils/TextEdit.fs @@ -6,7 +6,7 @@ open FsToolkit.ErrorHandling /// Functions to extract Cursor or Range from a given string. /// Cursor is marked in string with `$0` (`Cursor.Marker`) -/// +/// /// Note: Only `\n` is supported. Neither `\r\n` nor `\r` produce correct results. module Cursor = /// 0-based @@ -29,8 +29,8 @@ module Cursor = *) /// Returns Cursor Position BEFORE index - /// - /// Index might be `text.Length` (-> cursor AFTER last character). + /// + /// Index might be `text.Length` (-> cursor AFTER last character). /// All other out of text range indices throw exception. let beforeIndex (i: int) (text: string) : Position = assert(i >= 0) @@ -45,8 +45,8 @@ module Cursor = pos line char /// Returns index of first `$0` (`Cursor.Marker`) and the updated input text without the cursor marker. - /// - /// Note: Cursor Position is BEFORE index. + /// + /// Note: Cursor Position is BEFORE index. /// Note: Index might be `text.Length` (-> Cursor AFTER last char in text) let tryExtractIndex (text: string) = match text.IndexOf Marker with @@ -79,16 +79,16 @@ module Cursor = let tryFindAnyCursor (lines: string[]) = lines |> Seq.mapi (fun i l -> (i,l)) - |> Seq.tryPick (fun (i,line) -> - tryFindAnyCursorInLine line + |> Seq.tryPick (fun (i,line) -> + tryFindAnyCursorInLine line |> Option.map (fun (marker, c, line) -> (marker, pos i c, line)) ) |> function | None -> None - | Some (marker, p,line) -> + | Some (marker, p,line) -> lines.[p.Line] <- line Some ((marker, p), lines) - + let lines = text |> Text.lines match tryFindAnyCursor lines with | None -> None @@ -96,9 +96,9 @@ module Cursor = let text = lines |> String.concat "\n" Some ((marker, p), text) - /// Returns Position of first `$0` (`Cursor.Marker`) and the updated input text without the cursor marker. + /// Returns Position of first `$0` (`Cursor.Marker`) and the updated input text without the cursor marker. /// Only the first `$0` is processed. - /// + /// /// Note: Cursor Position is BETWEEN characters and might be outside of text range (cursor AFTER last character) let tryExtractPosition = tryExtractPositionMarkedWithAnyOf [| Marker |] @@ -109,7 +109,7 @@ module Cursor = >> Option.defaultWith (fun _ -> failtest "No cursor") /// Returns Range between the first two `$0` (`Cursor.Marker`) and the updated text without the two cursor markers. - /// + /// /// If there's only one cursor marker, the range covers exactly that position (`Start = End`) let tryExtractRange (text: string) = match tryExtractPosition text with @@ -125,9 +125,9 @@ module Cursor = /// Position is between characters, while index is on character. /// For Insert & Remove: character indices - /// + /// /// Returned index is AFTER cursor: - /// * `Column=0`: before first char; `Index=0`: on first char + /// * `Column=0`: before first char; `Index=0`: on first char /// * `Column=1`: after first char, before 2nd char; `Index=1`: on 2nd char /// * `Column=max`: after last char; `Index=max`: AFTER last char in line (-> `\n` or end of string) let tryIndexOf (pos: Position) (text: string) = @@ -157,7 +157,7 @@ module Cursor = >> Result.valueOr (failtestf "Invalid position: %s") /// Calculates cursors position after all edits are applied. - /// + /// /// When cursor inside a changed area: /// * deleted: cursor moves to start of deletion: /// ```fsharp @@ -184,7 +184,7 @@ module Cursor = /// let foo = 42 $0- 7 + 123 /// ``` /// -> like deletion - /// * Implementation detail: + /// * Implementation detail: /// Replacement is considered: First delete (-> move cursor to front), then insert (-> cursor stays) /// /// Note: `edits` must be sorted by range! @@ -213,7 +213,7 @@ module Cursor = else - e.Character + s.Character { Line = pos.Line + deltaLine; Character = pos.Character + deltaChar } - + // add new text to pos let pos = if System.String.IsNullOrEmpty edit.NewText then @@ -248,7 +248,7 @@ module Cursor = module Cursors = /// For each cursor (`$0`) in text: return text with just that one cursor - /// + /// /// Note: doesn't trim input! let iter (textWithCursors: string) = let rec collect (textsWithSingleCursor) (textWithCursors: string) = @@ -264,7 +264,7 @@ module Cursors = collect [] textWithCursors /// Returns all cursor (`$0`) positions and the text without any cursors. - /// + /// /// Unlike `iter` this extracts positions instead of reducing to texts with one cursor let extract (textWithCursors: string) = let tps = @@ -274,7 +274,7 @@ module Cursors = let text = tps |> List.head |> snd let poss = tps |> List.map fst (text, poss) - + /// Like `extract`, but instead of just extracting Cursors marked with `Cursor.Marker` (`$0`), /// this here extract all specified markers. @@ -337,8 +337,8 @@ module Text = module TextEdit = let apply (edit: TextEdit) = - // `edit` is from FSAC LSP -> might contain `\r`. - // But only `\n` handled by `Text.lines` -> remove `\r` + // `edit` is from FSAC LSP -> might contain `\r`. + // But only `\n` handled by `Text.lines` -> remove `\r` let newText = edit.NewText |> Text.removeCarriageReturn Text.replace edit.Range newText @@ -352,7 +352,7 @@ module TextEdit = && not (edit |> inserts) - // **Note**: + // **Note**: // VS Code allows TextEdits, that might not be strictly valid according to LSP Specs [^1]: // * inserts into not existing line (text has 2 line, insert into line 5 is ok) // * inserts into line way after last character (line has 15 char, insert into column 1000 is ok) @@ -360,9 +360,9 @@ module TextEdit = // * empty text edits (neither inserts nor deletes text) // // LSP Specs are quite vague. So above might or might not be ok according to Specs. - // But from FSAC perspective: Any case above most likely indicates an error in CodeFix implementation + // But from FSAC perspective: Any case above most likely indicates an error in CodeFix implementation // -> TextEdit must be STRICTLY correct and all of the cases above are considered erroneous! - // + // // [^1]: https://microsoft.github.io/language-server-protocol/specifications/specification-current/ /// Checks passed `edit` for errors: @@ -386,7 +386,7 @@ module TextEdit = Some "Expected change, but does nothing (neither delete nor insert)" else None - + module TextEdits = /// Checks edits for: @@ -394,13 +394,13 @@ module TextEdits = /// * All TextEdits are valid (`TextEdit.tryFindError`) /// * Edits don't overlap /// * For same position: All inserted before at most one replace (or delete) - /// - /// + /// + /// /// [LSP Specification for `TextEdit[]`](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textEditArray) - /// > Text edits ranges must never overlap, that means no part of the original document must be manipulated by more than one edit. - /// > However, it is possible that multiple edits have the same start position: multiple inserts, - /// > or any number of inserts followed by a single remove or replace edit. - /// > If multiple inserts have the same position, the order in the array defines the order + /// > Text edits ranges must never overlap, that means no part of the original document must be manipulated by more than one edit. + /// > However, it is possible that multiple edits have the same start position: multiple inserts, + /// > or any number of inserts followed by a single remove or replace edit. + /// > If multiple inserts have the same position, the order in the array defines the order /// > in which the inserted strings appear in the resulting text. let tryFindError (edits: TextEdit list) = let rec tryFindOverlappingEditExample (edits: TextEdit list) = @@ -413,7 +413,7 @@ module TextEdits = | None -> tryFindOverlappingEditExample edits let (|Overlapping|_|) = tryFindOverlappingEditExample - let (|Invalids|_|) = + let (|Invalids|_|) = List.choose (fun edit -> edit |> TextEdit.tryFindError |> Option.map (fun err -> (edit, err))) >> function | [] -> None | errs -> Some errs let findSameStarts (edits: TextEdit list) = @@ -439,7 +439,7 @@ module TextEdits = | [] -> Some "Expected at least one TextEdit, but were none" // edits should be valid | Invalids errs -> - sprintf + sprintf "Expected all TextEdits to be valid, but there was at least one erroneous Edit. Invalid Edits: %A" errs |> Some @@ -448,7 +448,7 @@ module TextEdits = Some $"Expected no overlaps, but at least two edits overlap: {edit1.Range} and {edit2.Range}" // For same position: all inserts must be before at most one Delete/Replace | ReplaceNotLast errs -> - sprintf + sprintf "Expected Inserts before at most one Delete/Replace, but there was at least one Delete/Before in invalid position: Invalid Edits: %A" errs |> Some @@ -482,7 +482,7 @@ module TextEdits = module WorkspaceEdit = /// Extract `TextEdit[]` from either `DocumentChanges` or `Changes`. /// All edits MUST be for passed `textDocument`. - /// + /// /// Checks for errors: /// * Either `DocumentChanges` or `Changes`, but not both /// * FsAutoComplete sends only `DocumentChanges` @@ -500,7 +500,7 @@ module WorkspaceEdit = else match textDocument.Version, version with // only compare `Version` when `textDocument` and `version` has a Version. Otherwise ignore - | Some textDocVersion, Some version when textDocVersion <> version -> + | Some textDocVersion, Some version when textDocVersion <> version -> Some $"Edit should be for document version `{textDocVersion}`, but version was `{version}`" | _ -> None diff --git a/test/FsAutoComplete.Tests.Lsp/paket.references b/test/FsAutoComplete.Tests.Lsp/paket.references index 52c6efe77..12261d103 100644 --- a/test/FsAutoComplete.Tests.Lsp/paket.references +++ b/test/FsAutoComplete.Tests.Lsp/paket.references @@ -15,3 +15,4 @@ Microsoft.Build copy_local:false Microsoft.Build.Framework copy_local:false Microsoft.Build.Utilities.Core copy_local:false Microsoft.Build.Tasks.Core copy_local: false +NuGet.Frameworks copy_local: false