diff --git a/src/FsAutoComplete.Core/AdaptiveExtensions.fs b/src/FsAutoComplete.Core/AdaptiveExtensions.fs
index 614869b24..2482990f5 100644
--- a/src/FsAutoComplete.Core/AdaptiveExtensions.fs
+++ b/src/FsAutoComplete.Core/AdaptiveExtensions.fs
@@ -480,46 +480,44 @@ module AsyncAVal =
let ofTask (value: Task<'a>) = ConstantVal(value) :> asyncaval<_>
let ofCancellableTask (value: CancellableTask<'a>) =
- ConstantVal(
- let cts = new CancellationTokenSource()
-
- let cancel () =
- cts.Cancel()
- cts.Dispose()
-
- let real =
- task {
- try
- return! value cts.Token
- finally
+ { new AbstractVal<'a>() with
+ member x.Compute t =
+ let cts = new CancellationTokenSource()
+
+ let cancel () =
+ cts.Cancel()
cts.Dispose()
- }
- AdaptiveCancellableTask(cancel, real)
- )
- :> asyncaval<_>
+ let real =
+ task {
+ try
+ return! value cts.Token
+ finally
+ cts.Dispose()
+ }
+ AdaptiveCancellableTask(cancel, real) }
+ :> asyncaval<_>
let ofAsync (value: Async<'a>) =
- ConstantVal(
- let cts = new CancellationTokenSource()
-
- let cancel () =
- cts.Cancel()
- cts.Dispose()
-
- let real =
- task {
- try
- return! Async.StartImmediateAsTask(value, cts.Token)
- finally
+ { new AbstractVal<'a>() with
+ member x.Compute t =
+ let cts = new CancellationTokenSource()
+
+ let cancel () =
+ cts.Cancel()
cts.Dispose()
- }
- AdaptiveCancellableTask(cancel, real)
- )
- :> asyncaval<_>
+ let real =
+ task {
+ try
+ return! Async.StartImmediateAsTask(value, cts.Token)
+ finally
+ cts.Dispose()
+ }
+ AdaptiveCancellableTask(cancel, real) }
+ :> asyncaval<_>
///
/// Creates an async adaptive value evaluation the given value.
@@ -604,7 +602,13 @@ module AsyncAVal =
/// adaptive inputs.
///
let mapSync (mapping: 'a -> CancellationToken -> 'b) (input: asyncaval<'a>) =
- map (fun a ct -> Task.FromResult(mapping a ct)) input
+ map
+ (fun a ct ->
+ if ct.IsCancellationRequested then
+ Task.FromCanceled<_>(ct)
+ else
+ Task.FromResult(mapping a ct))
+ input
///
/// Returns a new async adaptive value that adaptively applies the mapping function to the given
@@ -729,11 +733,10 @@ module AsyncAVal =
/// Returns a new async adaptive value that adaptively applies the mapping function to the given
/// optional adaptive inputs.
- let mapOption f (value: asyncaval<'a option>) : asyncaval<'b option> =
+ let mapOption (f: 'a -> CancellationToken -> 'b) (value: asyncaval<'a option>) : asyncaval<'b option> =
mapSync (fun data ctok -> data |> Option.map (fun d -> f d ctok)) value
type AsyncAValBuilder() =
-
member inline x.MergeSources(v1: asyncaval<'T1>, v2: asyncaval<'T2>) =
(v1, v2)
||> AsyncAVal.map2 (fun a b ctok ->
@@ -742,24 +745,24 @@ type AsyncAValBuilder() =
else
Task.FromResult(a, b))
-
- // member inline x.MergeSources3(v1 : aval<'T1>, v2 : aval<'T2>, v3 : aval<'T3>) =
- // AVal.map3 (fun a b c -> a,b,c) v1 v2 v3
-
member inline x.BindReturn(value: asyncaval<'T1>, [] mapping: 'T1 -> CancellationToken -> Task<'T2>) =
AsyncAVal.map mapping value
member inline x.BindReturn(value: asyncaval<'T1>, [] mapping: 'T1 -> Async<'T2>) =
AsyncAVal.mapAsync mapping value
- member inline x.BindReturn(value: asyncaval<'T1>, [] mapping: 'T1 -> Task<'T2>) =
- AsyncAVal.map (fun data _ -> mapping data) value
-
member inline x.Bind(value: asyncaval<'T1>, [] mapping: 'T1 -> CancellationToken -> asyncaval<'T2>) =
- AsyncAVal.bind (mapping) value
+ AsyncAVal.bind mapping value
member inline x.Bind(value: asyncaval<'T1>, [] mapping: 'T1 -> asyncaval<'T2>) =
- AsyncAVal.bind (fun data _ -> mapping data) value
+ AsyncAVal.bind
+ (fun data ct ->
+ if ct.IsCancellationRequested then
+ AsyncAVal.ConstantVal(Task.FromCanceled<_> ct)
+ else
+ mapping data)
+ value
+
member inline x.Return(value: 'T) = AsyncAVal.constant value
@@ -775,12 +778,14 @@ module AsyncAValBuilderExtensions =
member inline x.Source(value: aval<'T>) = AsyncAVal.ofAVal value
member inline x.Source(value: Task<'T>) = AsyncAVal.ofTask value
+ member inline x.Source(value: Async<'T>) = AsyncAVal.ofAsync value
+ member inline x.Source(value: CancellableTask<'T>) = AsyncAVal.ofCancellableTask value
member inline x.BindReturn(value: asyncaval<'T1>, [] mapping: 'T1 -> CancellationToken -> 'T2) =
AsyncAVal.mapSync (fun data ctok -> mapping data ctok) value
member inline x.BindReturn(value: asyncaval<'T1>, [] mapping: 'T1 -> 'T2) =
- AsyncAVal.mapSync (fun data ctok -> mapping data) value
+ AsyncAVal.mapSync (fun data _ -> mapping data) value
module AMapAsync =
diff --git a/src/FsAutoComplete.Core/AdaptiveExtensions.fsi b/src/FsAutoComplete.Core/AdaptiveExtensions.fsi
index cbe1d4e9e..fcb00ced8 100644
--- a/src/FsAutoComplete.Core/AdaptiveExtensions.fsi
+++ b/src/FsAutoComplete.Core/AdaptiveExtensions.fsi
@@ -323,8 +323,6 @@ type AsyncAValBuilder =
member inline Bind:
value: asyncaval<'T1> * mapping: ('T1 -> System.Threading.CancellationToken -> asyncaval<'T2>) -> asyncaval<'T2>
- member inline BindReturn: value: asyncaval<'T1> * mapping: ('T1 -> System.Threading.Tasks.Task<'T2>) -> asyncaval<'T2>
-
member inline BindReturn: value: asyncaval<'T1> * mapping: ('T1 -> Async<'T2>) -> asyncaval<'T2>
member inline BindReturn:
@@ -341,24 +339,19 @@ type AsyncAValBuilder =
[]
module AsyncAValBuilderExtensions =
-
+ open IcedTasks
val asyncAVal: AsyncAValBuilder
type AsyncAValBuilder with
member inline Source: value: FSharp.Data.Adaptive.aval<'T> -> asyncaval<'T>
-
- type AsyncAValBuilder with
-
member inline Source: value: System.Threading.Tasks.Task<'T> -> asyncaval<'T>
-
- type AsyncAValBuilder with
+ member inline Source: value: Async<'T> -> asyncaval<'T>
+ member inline Source: value: CancellableTask<'T> -> asyncaval<'T>
member inline BindReturn:
value: asyncaval<'T1> * mapping: ('T1 -> System.Threading.CancellationToken -> 'T2) -> asyncaval<'T2>
- type AsyncAValBuilder with
-
member inline BindReturn: value: asyncaval<'T1> * mapping: ('T1 -> 'T2) -> asyncaval<'T2>
module AMapAsync =
diff --git a/src/FsAutoComplete.Core/Commands.fs b/src/FsAutoComplete.Core/Commands.fs
index a70c78151..ff7fcc372 100644
--- a/src/FsAutoComplete.Core/Commands.fs
+++ b/src/FsAutoComplete.Core/Commands.fs
@@ -74,17 +74,17 @@ module AsyncResult =
let recoverCancellation (ar: Async, exn>>) =
recoverCancellationGeneric ar (sprintf "Request cancelled (exn was %A)" >> CoreResponse.InfoRes)
- let recoverCancellationIgnore (ar: Async>) = AsyncResult.foldResult id ignore ar
+ let recoverCancellationIgnore (ar: Async>) = ar |> AsyncResult.foldResult id (ignore)
[]
type NotificationEvent =
- | ParseError of errors: FSharpDiagnostic[] * file: string
+ | ParseError of errors: FSharpDiagnostic[] * file: string * version: int
| Workspace of ProjectSystem.ProjectResponse
- | AnalyzerMessage of messages: FSharp.Analyzers.SDK.Message[] * file: string
- | UnusedOpens of file: string * opens: Range[]
+ | AnalyzerMessage of messages: FSharp.Analyzers.SDK.Message[] * file: string * version: int
+ | UnusedOpens of file: string * opens: Range[] * version: int
// | Lint of file: string * warningsWithCodes: Lint.EnrichedLintWarning list
- | UnusedDeclarations of file: string * decls: range[]
- | SimplifyNames of file: string * names: SimplifyNames.SimplifiableRange[]
+ | UnusedDeclarations of file: string * decls: range[] * version: int
+ | SimplifyNames of file: string * names: SimplifyNames.SimplifiableRange[] * version: int
| Canceled of errorMessage: string
| FileParsed of string
| TestDetected of file: string * tests: TestAdapter.TestAdapterEntry[]
@@ -1251,7 +1251,7 @@ type Commands
//Diagnostics handler - Triggered by `CheckCore`
do
disposables.Add
- <| fileChecked.Publish.Subscribe(fun (parseAndCheck, file, _) ->
+ <| fileChecked.Publish.Subscribe(fun (parseAndCheck, file, version) ->
async {
try
NotificationEvent.FileParsed file |> notify.Trigger
@@ -1265,7 +1265,7 @@ type Commands
|> Array.distinctBy (fun e ->
e.Severity, e.ErrorNumber, e.StartLine, e.StartColumn, e.EndLine, e.EndColumn, e.Message)
- (errors, file) |> NotificationEvent.ParseError |> notify.Trigger
+ (errors, file, version) |> NotificationEvent.ParseError |> notify.Trigger
with _ ->
()
}
@@ -1274,7 +1274,7 @@ type Commands
//Analyzers handler - Triggered by `CheckCore`
do
disposables.Add
- <| fileChecked.Publish.Subscribe(fun (parseAndCheck, file, _) ->
+ <| fileChecked.Publish.Subscribe(fun (parseAndCheck, file, version) ->
async {
if hasAnalyzers then
try
@@ -1298,7 +1298,7 @@ type Commands
parseAndCheck.GetAllEntities
)
- (res, file) |> NotificationEvent.AnalyzerMessage |> notify.Trigger
+ (res, file, version) |> NotificationEvent.AnalyzerMessage |> notify.Trigger
Loggers.analyzers.info (
Log.setMessage "end analysis of {file}"
@@ -2435,6 +2435,7 @@ type Commands
let isScript = Utils.isAScript (UMX.untag file)
let! (opts, source) = state.TryGetFileCheckerOptionsWithSource file
+ let version = state.TryGetFileVersion file |> Option.defaultValue 0
let tyResOpt = checker.TryGetRecentCheckResultsForFile(file, opts, source)
@@ -2444,13 +2445,14 @@ type Commands
let! unused = UnusedDeclarations.getUnusedDeclarations (tyRes.GetCheckResults, isScript)
let unused = unused |> Seq.toArray
- notify.Trigger(NotificationEvent.UnusedDeclarations(file, unused))
+ notify.Trigger(NotificationEvent.UnusedDeclarations(file, unused, version))
}
|> Async.Ignore>
member x.CheckSimplifiedNames file : Async =
asyncResult {
let! (opts, source) = state.TryGetFileCheckerOptionsWithLines file
+ let version = state.TryGetFileVersion file |> Option.defaultValue 0
let tyResOpt = checker.TryGetRecentCheckResultsForFile(file, opts, source)
@@ -2461,7 +2463,7 @@ type Commands
let! simplified = SimplifyNames.getSimplifiableNames (tyRes.GetCheckResults, getSourceLine)
let simplified = Array.ofSeq simplified
- notify.Trigger(NotificationEvent.SimplifyNames(file, simplified))
+ notify.Trigger(NotificationEvent.SimplifyNames(file, simplified, version))
}
|> Async.Ignore>
|> x.AsCancellable file
@@ -2470,6 +2472,7 @@ type Commands
member x.CheckUnusedOpens file : Async =
asyncResult {
let! (opts, source) = state.TryGetFileCheckerOptionsWithLines file
+ let version = state.TryGetFileVersion file |> Option.defaultValue 0
match checker.TryGetRecentCheckResultsForFile(file, opts, source) with
| None -> return ()
@@ -2477,7 +2480,7 @@ type Commands
let! unused =
UnusedOpens.getUnusedOpens (tyRes.GetCheckResults, (fun i -> (source: ISourceText).GetLineString(i - 1)))
- notify.Trigger(NotificationEvent.UnusedOpens(file, (unused |> List.toArray)))
+ notify.Trigger(NotificationEvent.UnusedOpens(file, (unused |> List.toArray), version))
}
|> Async.Ignore>
diff --git a/src/FsAutoComplete.Core/FCSPatches.fs b/src/FsAutoComplete.Core/FCSPatches.fs
index 31f8be868..564ddeac3 100644
--- a/src/FsAutoComplete.Core/FCSPatches.fs
+++ b/src/FsAutoComplete.Core/FCSPatches.fs
@@ -7,6 +7,7 @@ open FSharp.Compiler.Syntax
open FSharp.Compiler.Text
open FsAutoComplete.UntypedAstUtils
open FSharp.Compiler.CodeAnalysis
+open FSharp.Compiler.EditorServices
module internal SynExprAppLocationsImpl =
let rec private searchSynArgExpr traverseSynExpr expr ranges =
@@ -350,6 +351,60 @@ type FSharpParseFileResults with
| _ -> defaultTraverse expr }
)
+ member scope.ClassifyBinding(binding: SynBinding) =
+ match binding with
+ | SynBinding(valData = SynValData(memberFlags = None)) -> FSharpGlyph.Delegate
+ | _ -> FSharpGlyph.Method
+
+ member scope.TryRangeOfNameOfNearestOuterBindingOrMember pos =
+ let tryGetIdentRangeFromBinding binding =
+ let glyph = scope.ClassifyBinding binding
+
+ match binding with
+ | SynBinding(headPat = headPat) ->
+ match headPat with
+ | SynPat.LongIdent(longDotId = longIdentWithDots) ->
+ Some(binding.RangeOfBindingWithRhs, glyph, longIdentWithDots.LongIdent)
+ | SynPat.As(rhsPat = SynPat.Named(ident = SynIdent(ident, _); isThisVal = false))
+ | SynPat.Named(SynIdent(ident, _), false, _, _) -> Some(binding.RangeOfBindingWithRhs, glyph, [ ident ])
+ | _ -> None
+
+ let rec walkBinding expr workingRange =
+ match expr with
+
+ // This lets us dive into subexpressions that may contain the binding we're after
+ | SynExpr.Sequential(_, _, expr1, expr2, _) ->
+ if Range.rangeContainsPos expr1.Range pos then
+ walkBinding expr1 workingRange
+ else
+ walkBinding expr2 workingRange
+
+ | SynExpr.LetOrUse(bindings = bindings; body = bodyExpr) ->
+ let potentialNestedRange =
+ bindings
+ |> List.tryFind (fun binding -> Range.rangeContainsPos binding.RangeOfBindingWithRhs pos)
+ |> Option.bind tryGetIdentRangeFromBinding
+
+ match potentialNestedRange with
+ | Some range -> walkBinding bodyExpr range
+ | None -> walkBinding bodyExpr workingRange
+
+ | _ -> Some workingRange
+
+ let visitor =
+ { new SyntaxVisitorBase<_>() with
+ override _.VisitExpr(_, _, defaultTraverse, expr) = defaultTraverse expr
+
+ override _.VisitBinding(_path, defaultTraverse, binding) =
+ match binding with
+ | SynBinding(expr = expr) as b when Range.rangeContainsPos b.RangeOfBindingWithRhs pos ->
+ match tryGetIdentRangeFromBinding b with
+ | Some range -> walkBinding expr range
+ | None -> None
+ | _ -> defaultTraverse binding }
+
+ SyntaxTraversal.Traverse(pos, scope.ParseTree, visitor)
+
module SyntaxTreeOps =
open FSharp.Compiler.Syntax
diff --git a/src/FsAutoComplete.Core/FCSPatches.fsi b/src/FsAutoComplete.Core/FCSPatches.fsi
index 42567b479..427831b30 100644
--- a/src/FsAutoComplete.Core/FCSPatches.fsi
+++ b/src/FsAutoComplete.Core/FCSPatches.fsi
@@ -6,6 +6,7 @@ open FSharp.Compiler.Syntax
open FSharp.Compiler.Text
open FsAutoComplete.UntypedAstUtils
open FSharp.Compiler.CodeAnalysis
+open FSharp.Compiler.EditorServices
type LanguageFeatureShim =
new: langFeature: string -> LanguageFeatureShim
@@ -27,3 +28,7 @@ module LanguageVersionShim =
module SyntaxTreeOps =
val synExprContainsError: SynExpr -> bool
+
+type FSharpParseFileResults with
+
+ member TryRangeOfNameOfNearestOuterBindingOrMember: pos: pos -> option
diff --git a/src/FsAutoComplete/LspHelpers.fs b/src/FsAutoComplete/LspHelpers.fs
index a7eb9fc1a..d83ebf57a 100644
--- a/src/FsAutoComplete/LspHelpers.fs
+++ b/src/FsAutoComplete/LspHelpers.fs
@@ -18,13 +18,14 @@ module FcsRange = FSharp.Compiler.Text.Range
type FcsPos = FSharp.Compiler.Text.Position
module FcsPos = FSharp.Compiler.Text.Position
+
module FcsPos =
let subtractColumn (pos: FcsPos) (column: int) = FcsPos.mkPos pos.Line (pos.Column - column)
[]
module Conversions =
- module Lsp = Ionide.LanguageServerProtocol.Types
+ module Lsp = Ionide.LanguageServerProtocol.Types
/// convert an LSP position to a compiler position
let protocolPosToPos (pos: Lsp.Position) : FcsPos = FcsPos.mkPos (pos.Line + 1) (pos.Character)
diff --git a/src/FsAutoComplete/LspHelpers.fsi b/src/FsAutoComplete/LspHelpers.fsi
index 5651e61b1..bd3d86ed3 100644
--- a/src/FsAutoComplete/LspHelpers.fsi
+++ b/src/FsAutoComplete/LspHelpers.fsi
@@ -15,6 +15,8 @@ module FcsRange = FSharp.Compiler.Text.Range
type FcsPos = FSharp.Compiler.Text.Position
module FcsPos = FSharp.Compiler.Text.Position
+module Lsp = Ionide.LanguageServerProtocol.Types
+
module FcsPos =
val subtractColumn: pos: FcsPos -> column: int -> FcsPos
diff --git a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs
index 93fa2dd73..54f2c9018 100644
--- a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs
+++ b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs
@@ -20,6 +20,7 @@ open System.Runtime.CompilerServices
open System.Runtime.InteropServices
open System.Buffers
open FsAutoComplete.Adaptive
+open FsAutoComplete.LspHelpers
open FSharp.Control.Reactive
open FsToolkit.ErrorHandling
@@ -47,6 +48,7 @@ open System.Text.RegularExpressions
open IcedTasks
open System.Threading.Tasks
open FsAutoComplete.FCSPatches
+open FSharp.Compiler.Syntax
[]
type WorkspaceChosen =
@@ -80,6 +82,7 @@ type LoadedProject =
member x.SourceFiles = x.FSharpProjectOptions.SourceFiles
member x.ProjectFileName = x.FSharpProjectOptions.ProjectFileName
+ static member op_Implicit(x: LoadedProject) = x.FSharpProjectOptions
type AdaptiveFSharpLspServer
@@ -303,7 +306,7 @@ type AdaptiveFSharpLspServer
let! unused = UnusedOpens.getUnusedOpens (tyRes.GetCheckResults, getSourceLine)
let! ct = Async.CancellationToken
- notifications.Trigger(NotificationEvent.UnusedOpens(filePath, (unused |> List.toArray)), ct)
+ notifications.Trigger(NotificationEvent.UnusedOpens(filePath, (unused |> List.toArray), file.Version), ct)
with e ->
logger.error (Log.setMessage "checkUnusedOpens failed" >> Log.addExn e)
}
@@ -319,7 +322,7 @@ type AdaptiveFSharpLspServer
let unused = unused |> Seq.toArray
let! ct = Async.CancellationToken
- notifications.Trigger(NotificationEvent.UnusedDeclarations(filePath, unused), ct)
+ notifications.Trigger(NotificationEvent.UnusedDeclarations(filePath, unused, file.Version), ct)
with e ->
logger.error (Log.setMessage "checkUnusedDeclarations failed" >> Log.addExn e)
}
@@ -333,7 +336,7 @@ type AdaptiveFSharpLspServer
let! simplified = SimplifyNames.getSimplifiableNames (tyRes.GetCheckResults, getSourceLine)
let simplified = Array.ofSeq simplified
let! ct = Async.CancellationToken
- notifications.Trigger(NotificationEvent.SimplifyNames(filePath, simplified), ct)
+ notifications.Trigger(NotificationEvent.SimplifyNames(filePath, simplified, file.Version), ct)
with e ->
logger.error (Log.setMessage "checkSimplifiedNames failed" >> Log.addExn e)
}
@@ -399,7 +402,7 @@ type AdaptiveFSharpLspServer
)
let! ct = Async.CancellationToken
- notifications.Trigger(NotificationEvent.AnalyzerMessage(res, file), ct)
+ notifications.Trigger(NotificationEvent.AnalyzerMessage(res, file, volatileFile.Version), ct)
Loggers.analyzers.info (Log.setMessageI $"end analysis of {file:file}")
@@ -452,12 +455,12 @@ type AdaptiveFSharpLspServer
logger.info (Log.setMessage "Workspace Notify {ws}" >> Log.addContextDestructured "ws" ws)
do! ({ Content = ws }: PlainNotification) |> lspClient.NotifyWorkspace
- | NotificationEvent.ParseError(errors, file) ->
+ | NotificationEvent.ParseError(errors, file, version) ->
let uri = Path.LocalPathToUri file
let diags = errors |> Array.map fcsErrorToDiagnostic
- diagnosticCollections.SetFor(uri, "F# Compiler", diags)
+ diagnosticCollections.SetFor(uri, "F# Compiler", version, diags)
- | NotificationEvent.UnusedOpens(file, opens) ->
+ | NotificationEvent.UnusedOpens(file, opens, version) ->
let uri = Path.LocalPathToUri file
let diags =
@@ -473,9 +476,9 @@ type AdaptiveFSharpLspServer
Data = None
CodeDescription = None })
- diagnosticCollections.SetFor(uri, "F# Unused opens", diags)
+ diagnosticCollections.SetFor(uri, "F# Unused opens", version, diags)
- | NotificationEvent.UnusedDeclarations(file, decls) ->
+ | NotificationEvent.UnusedDeclarations(file, decls, version) ->
let uri = Path.LocalPathToUri file
let diags =
@@ -491,9 +494,9 @@ type AdaptiveFSharpLspServer
Data = None
CodeDescription = None })
- diagnosticCollections.SetFor(uri, "F# Unused declarations", diags)
+ diagnosticCollections.SetFor(uri, "F# Unused declarations", version, diags)
- | NotificationEvent.SimplifyNames(file, decls) ->
+ | NotificationEvent.SimplifyNames(file, decls, version) ->
let uri = Path.LocalPathToUri file
let diags =
@@ -513,7 +516,7 @@ type AdaptiveFSharpLspServer
Data = None
CodeDescription = None })
- diagnosticCollections.SetFor(uri, "F# simplify names", diags)
+ diagnosticCollections.SetFor(uri, "F# simplify names", version, diags)
// | NotificationEvent.Lint (file, warnings) ->
// let uri = Path.LocalPathToUri file
@@ -558,11 +561,11 @@ type AdaptiveFSharpLspServer
let ntf: PlainNotification = { Content = msg }
do! lspClient.NotifyCancelledRequest ntf
- | NotificationEvent.AnalyzerMessage(messages, file) ->
+ | NotificationEvent.AnalyzerMessage(messages, file, version) ->
let uri = Path.LocalPathToUri file
match messages with
- | [||] -> diagnosticCollections.SetFor(uri, "F# Analyzers", [||])
+ | [||] -> diagnosticCollections.SetFor(uri, "F# Analyzers", version, [||])
| messages ->
let diags =
messages
@@ -596,7 +599,7 @@ type AdaptiveFSharpLspServer
CodeDescription = None
Data = fixes })
- diagnosticCollections.SetFor(uri, "F# Analyzers", diags)
+ diagnosticCollections.SetFor(uri, "F# Analyzers", version, diags)
| NotificationEvent.TestDetected(file, tests) ->
let rec map
(r: TestAdapter.TestAdapterEntry)
@@ -639,6 +642,32 @@ type AdaptiveFSharpLspServer
AdaptiveFile.GetLastWriteTimeUtc(UMX.untag filePath)
|> AVal.map (fun writeTime -> filePath, writeTime)
+
+ let readFileFromDisk lastTouched (file: string) =
+ async {
+ if File.Exists(UMX.untag file) then
+ use s = File.openFileStreamForReadingAsync file
+
+ let! source = sourceTextFactory.Create(file, s) |> Async.AwaitCancellableValueTask
+
+ return
+ { LastTouched = lastTouched
+ Source = source
+ Version = 0 }
+
+ else // When a user does "File -> New Text File -> Select a language -> F#" without saving, the file won't exist
+ return
+ { LastTouched = DateTime.UtcNow
+ Source = sourceTextFactory.Create(file, "")
+ Version = 0 }
+ }
+
+ let getLatestFileChange (filePath: string) =
+ asyncAVal {
+ let! (_, lastTouched) = getLastUTCChangeForFile filePath
+ return! readFileFromDisk lastTouched filePath
+ }
+
let addAValLogging cb (aval: aval<_>) =
let cb = aval.AddWeakMarkingCallback(cb)
aval |> AVal.mapDisposableTuple (fun x -> x, cb)
@@ -1026,7 +1055,7 @@ type AdaptiveFSharpLspServer
resetCancellationToken file.FileName
transact (fun () -> openFiles.AddOrElse(file.Source.FileName, adder, updater))
- let updateTextchanges filePath p =
+ let updateTextChanges filePath p =
let adder _ = cset<_> [ p ]
let updater _ (v: cset<_>) = v.Add p |> ignore
@@ -1039,6 +1068,7 @@ type AdaptiveFSharpLspServer
let forceFindOpenFile filePath = findFileInOpenFiles filePath |> AVal.force
+
let forceFindOpenFileOrRead file =
asyncOption {
@@ -1052,21 +1082,10 @@ type AdaptiveFSharpLspServer
>> Log.addContextDestructured "file" file
)
- if File.Exists(UMX.untag file) then
- use s = File.openFileStreamForReadingAsync file
+ let lastTouched = File.getLastWriteTimeOrDefaultNow file
- let! source = sourceTextFactory.Create(file, s) |> Async.AwaitCancellableValueTask
-
- return
- { LastTouched = File.getLastWriteTimeOrDefaultNow file
- Source = source
- Version = 0 }
+ return! readFileFromDisk lastTouched file
- else // When a user does "File -> New Text File -> Select a language -> F#" without saving, the file won't exist
- return
- { LastTouched = DateTime.UtcNow
- Source = sourceTextFactory.Create(file, "")
- Version = 0 }
with e ->
logger.warn (
Log.setMessage "Could not read file {file}"
@@ -1108,6 +1127,7 @@ type AdaptiveFSharpLspServer
}
+
/// Parses all files in the workspace. This is mostly used to trigger finding tests.
let parseAllFiles () =
asyncAVal {
@@ -1143,13 +1163,13 @@ type AdaptiveFSharpLspServer
and! tfmConfig = tfmConfig
let! projs =
- taskOption {
+ asyncOption {
let! cts = tryGetOpenFileToken filePath
+ use lcts = CancellationTokenSource.CreateLinkedTokenSource(ctok, cts.Token)
let! opts =
checker.GetProjectOptionsFromScript(filePath, file.Source, tfmConfig)
- |> Async.withCancellation cts.Token
- |> Async.startImmediateAsTask ctok
+ |> Async.withCancellationSafe (fun () -> lcts.Token)
opts |> scriptFileProjectOptions.Trigger
@@ -1168,14 +1188,42 @@ type AdaptiveFSharpLspServer
return file, projs
})
- let allFSharpProjectOptions =
+ let allFSharpFilesAndProjectOptions =
let wins =
openFilesToChangesAndProjectOptions
- |> AMap.map (fun k v -> v |> AsyncAVal.mapSync (fun d _ -> snd d))
+ |> AMap.map (fun k v -> v |> AsyncAVal.mapSync (fun (file, projects) _ -> Some file, projects))
+
+ let loses =
+ sourceFileToProjectOptions
+ |> AMap.map (fun filePath v ->
+ asyncAVal {
+ let! file = getLatestFileChange filePath
+ return (Some file, v)
+ })
- let loses = sourceFileToProjectOptions |> AMap.map (fun k v -> AsyncAVal.constant v)
AMap.union loses wins
+ let allFSharpProjectOptions =
+ allFSharpFilesAndProjectOptions
+ |> AMapAsync.mapAsyncAVal (fun filePath (file, options) ctok -> AsyncAVal.constant options)
+
+ let allFilesParsed =
+ allFSharpFilesAndProjectOptions
+ |> AMapAsync.mapAsyncAVal (fun filePath (file, options: LoadedProject list) ctok ->
+ asyncAVal {
+ let! (checker: FSharpCompilerServiceChecker) = checker
+
+ return!
+ asyncOption {
+ let! project = options |> selectProject
+ let options = project.FSharpProjectOptions
+ let parseOpts = Utils.projectOptionsToParseOptions project.FSharpProjectOptions
+ let! file = file
+ return! parseFile checker file parseOpts options
+ }
+
+ })
+
let getAllProjectOptions () =
async {
@@ -1292,7 +1340,7 @@ type AdaptiveFSharpLspServer
|> Array.distinctBy (fun e ->
e.Severity, e.ErrorNumber, e.StartLine, e.StartColumn, e.EndLine, e.EndColumn, e.Message)
- notifications.Trigger(NotificationEvent.ParseError(errors, file.Source.FileName), ct)
+ notifications.Trigger(NotificationEvent.ParseError(errors, file.Source.FileName, file.Version), ct)
},
ct
)
@@ -1303,7 +1351,7 @@ type AdaptiveFSharpLspServer
/// Bypass Adaptive checking and tell the checker to check a file
let bypassAdaptiveTypeCheck (filePath: string) opts =
- async {
+ asyncResult {
try
logger.info (
Log.setMessage "Forced Check : {file}"
@@ -1312,10 +1360,10 @@ type AdaptiveFSharpLspServer
let checker = checker |> AVal.force
- match! forceFindOpenFileOrRead filePath with
+ let! fileInfo = forceFindOpenFileOrRead filePath
// Don't cache for autocompletions as we really only want to cache "Opened" files.
- | Ok(fileInfo) -> return! parseAndCheckFile checker fileInfo opts false |> Async.Ignore
- | _ -> ()
+ return! parseAndCheckFile checker fileInfo opts false
+
with e ->
logger.warn (
@@ -1323,28 +1371,9 @@ type AdaptiveFSharpLspServer
>> Log.addContextDestructured "file" filePath
>> Log.addExn e
)
- }
-
- let openFilesToParsedResults =
- openFilesToChangesAndProjectOptions
- |> AMapAsync.mapAsyncAVal (fun _ (info, projectOptions) ctok ->
- asyncAVal {
- let file = info.Source.FileName
- let! checker = checker
-
- return!
- taskOption {
- let! opts = selectProject projectOptions
- and! cts = tryGetOpenFileToken file
- let parseOpts = Utils.projectOptionsToParseOptions opts.FSharpProjectOptions
-
- return!
- parseFile checker info parseOpts opts.FSharpProjectOptions
- |> Async.withCancellation cts.Token
- |> Async.startImmediateAsTask ctok
- }
- })
+ return! Error(e.ToString())
+ }
let openFilesToRecentCheckedFilesResults =
@@ -1369,23 +1398,23 @@ type AdaptiveFSharpLspServer
let! checker = checker
return!
- taskOption {
+ asyncOption {
let! opts = selectProject projectOptions
- and! cts = tryGetOpenFileToken file
+ let! cts = tryGetOpenFileToken file
+ use lcts = CancellationTokenSource.CreateLinkedTokenSource(ctok, cts.Token)
return!
parseAndCheckFile checker info opts.FSharpProjectOptions true
- |> Async.withCancellation cts.Token
- |> fun work -> Async.StartImmediateAsTask(work, ctok)
+ |> Async.withCancellationSafe (fun () -> lcts.Token)
}
})
- let getParseResults filePath = openFilesToParsedResults |> AMapAsync.tryFindAndFlatten filePath
+ let getParseResults filePath = allFilesParsed |> AMapAsync.tryFindAndFlatten filePath
- let getTypeCheckResults filePath = openFilesToCheckedFilesResults |> AMapAsync.tryFindAndFlatten (filePath)
+ let getOpenFileTypeCheckResults filePath = openFilesToCheckedFilesResults |> AMapAsync.tryFindAndFlatten (filePath)
- let getRecentTypeCheckResults filePath =
+ let getOpenFileRecentTypeCheckResults filePath =
openFilesToRecentCheckedFilesResults |> AMapAsync.tryFindAndFlatten (filePath)
let tryGetLineStr pos (text: IFSACSourceText) =
@@ -1398,15 +1427,15 @@ type AdaptiveFSharpLspServer
return results |> Result.ofOption (fun () -> $"No parse results for {filePath}")
}
- let forceGetRecentTypeCheckResults filePath =
+ let forceGetOpenFileRecentTypeCheckResults filePath =
async {
- let! results = getRecentTypeCheckResults filePath |> AsyncAVal.forceAsync
+ let! results = getOpenFileRecentTypeCheckResults filePath |> AsyncAVal.forceAsync
return results |> Result.ofOption (fun () -> $"No typecheck results for {filePath}")
}
- let forceGetTypeCheckResults (filePath: string) =
+ let forceGetOpenFileTypeCheckResults (filePath: string) =
async {
- let! results = getTypeCheckResults (filePath) |> AsyncAVal.forceAsync
+ let! results = getOpenFileTypeCheckResults (filePath) |> AsyncAVal.forceAsync
return results |> Result.ofOption (fun () -> $"No typecheck results for {filePath}")
}
@@ -1421,7 +1450,7 @@ type AdaptiveFSharpLspServer
///
/// The name of the file in the project whose source to find a typecheck.
/// A Result of ParseAndCheckResults
- let forceGetTypeCheckResultsStale (filePath: string) =
+ let forceGetOpenFileTypeCheckResultsStale (filePath: string) =
asyncAVal {
let! (checker: FSharpCompilerServiceChecker) = checker
@@ -1432,15 +1461,15 @@ type AdaptiveFSharpLspServer
return
tryGetLastCheckResultForFile filePath
- |> AsyncResult.orElseWith (fun _ -> forceGetRecentTypeCheckResults filePath)
- |> AsyncResult.orElseWith (fun _ -> forceGetTypeCheckResults filePath)
+ |> AsyncResult.orElseWith (fun _ -> forceGetOpenFileRecentTypeCheckResults filePath)
+ |> AsyncResult.orElseWith (fun _ -> forceGetOpenFileTypeCheckResults filePath)
|> Async.map (fun r ->
Async.Start(
async {
// This needs to be in a try catch as it can throw on cancellation which causes the server to crash
try
do!
- forceGetTypeCheckResults filePath
+ forceGetOpenFileTypeCheckResults filePath
|> Async.Ignore>
with e ->
()
@@ -1451,15 +1480,14 @@ type AdaptiveFSharpLspServer
}
|> AsyncAVal.forceAsync
-
- let openFilesToDeclarations =
- openFilesToParsedResults
+ let allFilesToDeclarations =
+ allFilesParsed
|> AMap.map (fun k v -> v |> AsyncAVal.mapOption (fun p _ -> p.GetNavigationItems().Declarations))
- let getAllOpenDeclarations () =
+ let getAllDeclarations () =
async {
let! results =
- openFilesToDeclarations
+ allFilesToDeclarations
|> AMap.force
|> HashMap.toArray
|> Array.map (fun (k, v) ->
@@ -1473,7 +1501,7 @@ type AdaptiveFSharpLspServer
}
- let getDeclarations filename = openFilesToDeclarations |> AMapAsync.tryFindAndFlatten filename
+ let getDeclarations filename = allFilesToDeclarations |> AMapAsync.tryFindAndFlatten filename
let getFilePathAndPosition (p: ITextDocumentPositionParams) =
let filePath = p.GetFilePath() |> Utils.normalizePath
@@ -1481,7 +1509,6 @@ type AdaptiveFSharpLspServer
filePath, pos
-
let forceGetProjectOptions filePath =
asyncAVal {
let! projects = getProjectOptionsForFile filePath
@@ -1528,7 +1555,7 @@ type AdaptiveFSharpLspServer
if symbol.Kind = kind then
let! (text) = forceFindOpenFileOrRead fileName |> Async.map Option.ofResult
let! line = tryGetLineStr pos text.Source |> Option.ofResult
- let! tyRes = forceGetTypeCheckResults fileName |> Async.map (Option.ofResult)
+ let! tyRes = forceGetOpenFileTypeCheckResults fileName |> Async.map (Option.ofResult)
let symbolUse = tyRes.TryGetSymbolUse pos line
return! Some(symbol, symbolUse)
else
@@ -1614,7 +1641,7 @@ type AdaptiveFSharpLspServer
return! checker.FindReferencesForSymbolInFile(UMX.untag file, project, symbol)
else
// untitled script files
- match! forceGetTypeCheckResultsStale file with
+ match! forceGetOpenFileTypeCheckResultsStale file with
| Error _ -> return Seq.empty
| Ok tyRes ->
let! ct = Async.CancellationToken
@@ -1657,7 +1684,7 @@ type AdaptiveFSharpLspServer
return! checker.FindReferencesForSymbolInFile(UMX.untag file, project, symbol)
else
// untitled script files
- match! forceGetTypeCheckResultsStale file with
+ match! forceGetOpenFileTypeCheckResultsStale file with
| Error _ -> return Seq.empty
| Ok tyRes ->
let! ct = Async.CancellationToken
@@ -1688,7 +1715,7 @@ type AdaptiveFSharpLspServer
asyncResult {
let! (file) = forceFindOpenFileOrRead filePath
let! lineStr = file.Source |> tryGetLineStr pos
- and! tyRes = forceGetTypeCheckResults filePath
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath
return tyRes, lineStr, file.Source
}
@@ -1989,7 +2016,7 @@ type AdaptiveFSharpLspServer
member private x.handleSemanticTokens (filePath: string) range : AsyncLspResult =
asyncResult {
- let! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ let! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let r = tyRes.GetCheckResults.GetSemanticClassification(range)
let filteredRanges = Commands.scrubRanges r
@@ -2325,7 +2352,7 @@ type AdaptiveFSharpLspServer
VolatileFile.Create(sourceTextFactory.Create(filePath, doc.Text), doc.Version)
updateOpenFiles file
- let! _ = forceGetTypeCheckResults filePath
+ let! _ = forceGetOpenFileTypeCheckResults filePath
return ()
with e ->
trace |> Tracing.recordException e
@@ -2380,9 +2407,9 @@ type AdaptiveFSharpLspServer
let doc = p.TextDocument
let filePath = doc.GetFilePath() |> Utils.normalizePath
- updateTextchanges filePath (p, DateTime.UtcNow)
+ updateTextChanges filePath (p, DateTime.UtcNow)
- let! _ = forceGetTypeCheckResults filePath
+ let! _ = forceGetOpenFileTypeCheckResults filePath
return ()
@@ -2433,7 +2460,7 @@ type AdaptiveFSharpLspServer
updateOpenFiles file
textChanges.Remove filePath |> ignore)
- let! _ = forceGetTypeCheckResults filePath
+ let! _ = forceGetOpenFileTypeCheckResults filePath
do! bypassAdaptiveAndCheckDepenenciesForFile filePath
do! lspClient.CodeLensRefresh()
@@ -2521,7 +2548,7 @@ type AdaptiveFSharpLspServer
let! typeCheckResults =
if isSpecialChar previousCharacter then
- forceGetTypeCheckResults filePath
+ forceGetOpenFileTypeCheckResults filePath
else
forceGetTypeCheckResultsStale filePath
@@ -2545,15 +2572,15 @@ type AdaptiveFSharpLspServer
match e with
| "Should not have empty completions" ->
// If we don't get any completions, assume we need to wait for a full typecheck
- getCompletions forceGetTypeCheckResults
- | _ -> getCompletions forceGetTypeCheckResultsStale
+ getCompletions forceGetOpenFileTypeCheckResults
+ | _ -> getCompletions forceGetOpenFileTypeCheckResultsStale
match!
retryAsyncOption
(TimeSpan.FromMilliseconds(15.))
100
handleError
- (getCompletions forceGetTypeCheckResultsStale)
+ (getCompletions forceGetOpenFileTypeCheckResultsStale)
|> AsyncResult.ofStringErr
with
| None -> return! success (None)
@@ -2736,7 +2763,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
@@ -2802,7 +2829,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResultsStale filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResultsStale filePath |> AsyncResult.ofStringErr
match tyRes.TryGetToolTipEnhanced pos lineStr with
| Ok(Some tooltipResult) ->
@@ -2895,7 +2922,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- let! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ let! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let! (_, _, range) =
Commands.renameSymbolRange getDeclarationLocation false pos lineStr volatileFile.Source tyRes
@@ -2918,7 +2945,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
// validate name and surround with backticks if necessary
let! newName =
@@ -2990,7 +3017,7 @@ type AdaptiveFSharpLspServer
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let! decl = tyRes.TryFindDeclaration pos lineStr |> AsyncResult.ofStringErr
return decl |> findDeclToLspLocation |> GotoResult.Single |> Some
with e ->
@@ -3020,7 +3047,7 @@ type AdaptiveFSharpLspServer
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let! decl = tyRes.TryFindTypeDeclaration pos lineStr |> AsyncResult.ofStringErr
return decl |> findDeclToLspLocation |> GotoResult.Single |> Some
with e ->
@@ -3049,7 +3076,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = tryGetLineStr pos volatileFile.Source |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let! usages =
symbolUseWorkspace true true false pos lineStr volatileFile.Source tyRes
@@ -3085,7 +3112,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = tryGetLineStr pos volatileFile.Source |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
match
tyRes.TryGetSymbolUseAndUsages pos lineStr
@@ -3127,7 +3154,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = tryGetLineStr pos volatileFile.Source |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
logger.info (
Log.setMessage "TextDocumentImplementation Request: {parms}"
@@ -3237,7 +3264,7 @@ type AdaptiveFSharpLspServer
let glyphToSymbolKind = glyphToSymbolKind |> AVal.force
- let! decls = getAllOpenDeclarations ()
+ let! decls = getAllDeclarations ()
let res =
decls
@@ -3488,7 +3515,7 @@ type AdaptiveFSharpLspServer
let filePath = Path.FileUriToLocalPath data.[0] |> Utils.normalizePath
try
- let! tyRes = forceGetTypeCheckResultsStale filePath |> AsyncResult.ofStringErr
+ let! tyRes = forceGetOpenFileTypeCheckResultsStale filePath |> AsyncResult.ofStringErr
logger.info (
@@ -3821,7 +3848,7 @@ type AdaptiveFSharpLspServer
let filePath = p.TextDocument.GetFilePath() |> Utils.normalizePath
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let fcsRange = protocolRangeToRange (UMX.untag filePath) p.Range
let config = config |> AVal.force
@@ -3927,7 +3954,7 @@ type AdaptiveFSharpLspServer
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
- let! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ let! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let fcsRange = protocolRangeToRange (UMX.untag filePath) p.Range
@@ -3993,11 +4020,143 @@ type AdaptiveFSharpLspServer
override x.WorkspaceWillRenameFiles p = x.logUnimplementedRequest p
- override x.CallHierarchyIncomingCalls p = x.logUnimplementedRequest p
+ override x.CallHierarchyIncomingCalls(p: CallHierarchyIncomingCallsParams) =
+ asyncResult {
+ // IncomingCalls is a recursive "Find All References".
+ let tags = [ "CallHierarchyIncomingCalls", box p ]
+ use trace = fsacActivitySource.StartActivityForType(thisType, tags = tags)
- override x.CallHierarchyOutgoingCalls p = x.logUnimplementedRequest p
+ try
+ logger.info (
+ Log.setMessage "CallHierarchyIncomingCalls Request: {parms}"
+ >> Log.addContextDestructured "parms" p
+ )
+
+ let filePath = Path.FileUriToLocalPath p.Item.Uri |> Utils.normalizePath
+ let pos = protocolPosToPos p.Item.SelectionRange.Start
+ let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
+ let! lineStr = tryGetLineStr pos volatileFile.Source |> Result.ofStringErr
+ and! opts = forceGetProjectOptions filePath |> AsyncResult.ofStringErr
+ // Incoming file may not be "Opened" so we need to force a typecheck
+ let! tyRes = bypassAdaptiveTypeCheck filePath opts |> AsyncResult.ofStringErr
- override x.TextDocumentPrepareCallHierarchy p = x.logUnimplementedRequest p
+
+ let locationToCallHierarchyItem (loc: Location) =
+ asyncOption {
+
+ // Don't process ourselves
+ if p.Item.SelectionRange.Start = loc.Range.Start then
+ do! None
+
+ let fn = loc.Uri |> Path.FileUriToLocalPath |> Utils.normalizePath
+
+ let! parseResults = getParseResults fn |> AsyncAVal.forceAsync
+
+ let! (fullBindingRange, glyph, bindingIdents) =
+ parseResults.TryRangeOfNameOfNearestOuterBindingOrMember(protocolPosToPos loc.Range.Start)
+
+ // We only want to use the last identifiers range because if we have a member like `self.MyMember`
+ // F# Find Usages only works with the last identifier's range so we want to use `MyMember`.
+ let! endRange = bindingIdents |> Seq.tryLast
+
+ // However we still want to display that whole name.
+ let name = bindingIdents |> Seq.map (fun x -> x.idText) |> String.concat "."
+
+ let retVals =
+ { From =
+ { Name = name
+ Kind = (AVal.force glyphToSymbolKind) glyph |> Option.defaultValue SymbolKind.Method
+ Tags = None
+ Detail = Some(sprintf $"From {Path.GetFileName(UMX.untag fn)}")
+ Uri = loc.Uri
+ Range = fcsRangeToLsp fullBindingRange
+ SelectionRange = fcsRangeToLsp endRange.idRange
+ Data = None }
+ FromRanges = [| loc.Range |] }
+
+ return retVals
+ }
+
+ let! usages =
+ symbolUseWorkspace true true false pos lineStr volatileFile.Source tyRes
+ |> AsyncResult.mapError (JsonRpc.Error.InternalErrorMessage)
+
+ let! references =
+ usages.Values
+ |> Seq.collect (Seq.map fcsRangeToLspLocation)
+ |> Seq.toArray
+ |> Array.map locationToCallHierarchyItem
+ |> Async.parallel75
+ |> Async.map (Array.choose id)
+
+ return Some references
+ with e ->
+ trace |> Tracing.recordException e
+
+ logger.error (
+ Log.setMessage "CallHierarchyIncomingCalls Request Errored {p}"
+ >> Log.addContextDestructured "p" p
+ >> Log.addExn e
+ )
+
+ return! returnException e
+
+ }
+
+
+
+ override x.TextDocumentPrepareCallHierarchy(p: CallHierarchyPrepareParams) =
+ asyncResult {
+ let tags = [ "CallHierarchyPrepareParams", box p ]
+ use trace = fsacActivitySource.StartActivityForType(thisType, tags = tags)
+
+ try
+ logger.info (
+ Log.setMessage "CallHierarchyPrepareParams Request: {parms}"
+ >> Log.addContextDestructured "parms" p
+ )
+
+ let (filePath, pos) =
+ { new ITextDocumentPositionParams with
+ member __.TextDocument = p.TextDocument
+ member __.Position = p.Position }
+ |> getFilePathAndPosition
+
+ let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
+ let! lineStr = tryGetLineStr pos volatileFile.Source |> Result.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
+
+ let! decl = tyRes.TryFindDeclaration pos lineStr |> AsyncResult.ofStringErr
+
+ let! lexedResult =
+ Lexer.getSymbol pos.Line pos.Column lineStr SymbolLookupKind.Fuzzy [||]
+ |> Result.ofOption (fun () -> "No symbol found")
+ |> Result.ofStringErr
+
+ let location = findDeclToLspLocation decl
+
+ let returnValue =
+ [| { Name = lexedResult.Text
+ Kind = SymbolKind.Function
+ Tags = None
+ Detail = None
+ Uri = location.Uri
+ Range = location.Range
+ SelectionRange = location.Range
+ Data = None } |]
+
+ return Some returnValue
+ with e ->
+ trace |> Tracing.recordException e
+
+ logger.error (
+ Log.setMessage "CallHierarchyPrepareParams Request Errored {p}"
+ >> Log.addContextDestructured "p" p
+ >> Log.addExn e
+ )
+
+ return! returnException e
+ }
override x.TextDocumentPrepareTypeHierarchy p = x.logUnimplementedRequest p
@@ -4047,7 +4206,7 @@ type AdaptiveFSharpLspServer
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let! tip = Commands.typesig tyRes pos lineStr |> Result.ofCoreResponse
return
@@ -4083,7 +4242,7 @@ type AdaptiveFSharpLspServer
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
let! (typ, parms, generics) = tyRes.TryGetSignatureData pos lineStr |> Result.ofStringErr
return
@@ -4118,7 +4277,7 @@ type AdaptiveFSharpLspServer
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
match!
Commands.GenerateXmlDocumentation(tyRes, pos, lineStr)
@@ -4467,7 +4626,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
match! Commands.Help tyRes pos lineStr |> Result.ofCoreResponse with
| Some t -> return Some { Content = CommandResponse.help FsAutoComplete.JsonSerializer.writeJson t }
@@ -4498,7 +4657,7 @@ type AdaptiveFSharpLspServer
let (filePath, pos) = getFilePathAndPosition p
let! volatileFile = forceFindOpenFileOrRead filePath |> AsyncResult.ofStringErr
let! lineStr = volatileFile.Source |> tryGetLineStr pos |> Result.ofStringErr
- and! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ and! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
lastFSharpDocumentationTypeCheck <- Some tyRes
match! Commands.FormattedDocumentation tyRes pos lineStr |> Result.ofCoreResponse with
@@ -4608,7 +4767,7 @@ type AdaptiveFSharpLspServer
)
let filePath = p.TextDocument.GetFilePath() |> Utils.normalizePath
- let! tyRes = forceGetTypeCheckResults filePath |> AsyncResult.ofStringErr
+ let! tyRes = forceGetOpenFileTypeCheckResults filePath |> AsyncResult.ofStringErr
match! Commands.pipelineHints forceFindSourceText tyRes |> AsyncResult.ofCoreResponse with
| None -> return None
@@ -4894,6 +5053,11 @@ type AdaptiveFSharpLspServer
return ()
}
+ member this.CallHierarchyOutgoingCalls
+ (arg1: CallHierarchyOutgoingCallsParams)
+ : AsyncLspResult =
+ AsyncLspResult.notImplemented
+
module AdaptiveFSharpLspServer =
open System.Threading.Tasks
diff --git a/src/FsAutoComplete/LspServers/Common.fs b/src/FsAutoComplete/LspServers/Common.fs
index 999489c1a..ceeb34798 100644
--- a/src/FsAutoComplete/LspServers/Common.fs
+++ b/src/FsAutoComplete/LspServers/Common.fs
@@ -47,12 +47,13 @@ module AsyncResult =
type DiagnosticMessage =
- | Add of source: string * diags: Diagnostic[]
+ | Add of source: string * Version * diags: Diagnostic[]
| Clear of source: string
/// a type that handles bookkeeping for sending file diagnostics. It will debounce calls and handle sending diagnostics via the configured function when safe
type DiagnosticCollection(sendDiagnostics: DocumentUri -> Diagnostic[] -> Async) =
- let send uri (diags: Map) = Map.toArray diags |> Array.collect snd |> sendDiagnostics uri
+ let send uri (diags: Map) =
+ Map.toArray diags |> Array.collect (snd >> snd) |> sendDiagnostics uri
let agents =
System.Collections.Concurrent.ConcurrentDictionary *
@@ -74,13 +75,16 @@ type DiagnosticCollection(sendDiagnostics: DocumentUri -> Diagnostic[] -> Async<
let mailbox =
MailboxProcessor.Start(
(fun inbox ->
- let rec loop (state: Map) =
+ let rec loop (state: Map) =
async {
match! inbox.Receive() with
- | Add(source, diags) ->
- let newState = state |> Map.add source diags
- do! send uri newState
- return! loop newState
+ | Add(source, version, diags) ->
+ match Map.tryFind source state with
+ | Some(oldVersion, _) when oldVersion > version -> return! loop state
+ | _ ->
+ let newState = state |> Map.add source (version, diags)
+ do! send uri newState
+ return! loop newState
| Clear source ->
let newState = state |> Map.remove source
do! send uri newState
@@ -114,13 +118,13 @@ type DiagnosticCollection(sendDiagnostics: DocumentUri -> Diagnostic[] -> Async<
/// If false, no diagnostics will be collected or sent to the client
member val ClientSupportsDiagnostics = true with get, set
- member x.SetFor(fileUri: DocumentUri, kind: string, values: Diagnostic[]) =
+ member x.SetFor(fileUri: DocumentUri, kind: string, version: Version, values: Diagnostic[]) =
if x.ClientSupportsDiagnostics then
let mailbox = getOrAddAgent fileUri
match values with
| [||] -> mailbox.Post(Clear kind)
- | values -> mailbox.Post(Add(kind, values))
+ | values -> mailbox.Post(Add(kind, version, values))
member x.ClearFor(fileUri: DocumentUri) =
if x.ClientSupportsDiagnostics then
@@ -241,6 +245,7 @@ module Helpers =
Save = Some { IncludeText = Some true } }
FoldingRangeProvider = Some true
SelectionRangeProvider = Some true
+ CallHierarchyProvider = Some true
SemanticTokensProvider =
Some
{ Legend =
diff --git a/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs b/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs
index a55b50f5c..9c842284d 100644
--- a/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs
+++ b/src/FsAutoComplete/LspServers/FsAutoComplete.Lsp.fs
@@ -220,12 +220,12 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient, sourceTextFactory
|> lspClient.NotifyWorkspace
|> Async.Start
- | NotificationEvent.ParseError(errors, file) ->
+ | NotificationEvent.ParseError(errors, file, version) ->
let uri = Path.LocalPathToUri file
let diags = errors |> Array.map fcsErrorToDiagnostic
- diagnosticCollections.SetFor(uri, "F# Compiler", diags)
+ diagnosticCollections.SetFor(uri, "F# Compiler", version, diags)
- | NotificationEvent.UnusedOpens(file, opens) ->
+ | NotificationEvent.UnusedOpens(file, opens, version) ->
let uri = Path.LocalPathToUri file
let diags =
@@ -241,9 +241,9 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient, sourceTextFactory
Data = None
CodeDescription = None })
- diagnosticCollections.SetFor(uri, "F# Unused opens", diags)
+ diagnosticCollections.SetFor(uri, "F# Unused opens", version, diags)
- | NotificationEvent.UnusedDeclarations(file, decls) ->
+ | NotificationEvent.UnusedDeclarations(file, decls, version) ->
let uri = Path.LocalPathToUri file
let diags =
@@ -259,9 +259,9 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient, sourceTextFactory
Data = None
CodeDescription = None })
- diagnosticCollections.SetFor(uri, "F# Unused declarations", diags)
+ diagnosticCollections.SetFor(uri, "F# Unused declarations", version, diags)
- | NotificationEvent.SimplifyNames(file, decls) ->
+ | NotificationEvent.SimplifyNames(file, decls, version) ->
let uri = Path.LocalPathToUri file
let diags =
@@ -283,7 +283,7 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient, sourceTextFactory
Data = None
CodeDescription = None })
- diagnosticCollections.SetFor(uri, "F# simplify names", diags)
+ diagnosticCollections.SetFor(uri, "F# simplify names", version, diags)
// | NotificationEvent.Lint (file, warnings) ->
// let uri = Path.LocalPathToUri file
@@ -328,11 +328,11 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient, sourceTextFactory
let ntf: PlainNotification = { Content = msg }
lspClient.NotifyCancelledRequest ntf |> Async.Start
- | NotificationEvent.AnalyzerMessage(messages, file) ->
+ | NotificationEvent.AnalyzerMessage(messages, file, version) ->
let uri = Path.LocalPathToUri file
match messages with
- | [||] -> diagnosticCollections.SetFor(uri, "F# Analyzers", [||])
+ | [||] -> diagnosticCollections.SetFor(uri, "F# Analyzers", version, [||])
| messages ->
let diags =
messages
@@ -366,7 +366,7 @@ type FSharpLspServer(state: State, lspClient: FSharpLspClient, sourceTextFactory
CodeDescription = None
Data = fixes })
- diagnosticCollections.SetFor(uri, "F# Analyzers", diags)
+ diagnosticCollections.SetFor(uri, "F# Analyzers", version, diags)
| NotificationEvent.TestDetected(file, tests) ->
let rec map
(r: TestAdapter.TestAdapterEntry)
diff --git a/test/FsAutoComplete.Tests.Lsp/CallHierarchyTests.fs b/test/FsAutoComplete.Tests.Lsp/CallHierarchyTests.fs
new file mode 100644
index 000000000..4e9ca9b91
--- /dev/null
+++ b/test/FsAutoComplete.Tests.Lsp/CallHierarchyTests.fs
@@ -0,0 +1,97 @@
+module FsAutoComplete.Tests.CallHierarchy
+open Expecto
+open FSharp.Compiler.Syntax
+open FSharp.Compiler
+open FSharp.Compiler.CodeAnalysis
+open System.IO
+open FsAutoComplete
+open Ionide.ProjInfo.ProjectSystem
+open FSharp.Compiler.Text
+open Utils.ServerTests
+open Helpers
+open Utils.Server
+open Ionide.LanguageServerProtocol.Types
+
+let examples = Path.Combine(__SOURCE_DIRECTORY__, "TestCases", "CallHierarchy")
+let incomingExamples = Path.Combine(examples, "IncomingCalls")
+let sourceFactory : ISourceTextFactory = RoslynSourceTextFactory()
+let resultGet = function | Ok x -> x | Error e -> failwithf "%A" e
+let resultOptionGet =
+ function
+ | Ok (Some x) -> x
+ | Ok (None) -> failwithf "Expected Some, got None"
+ | Error e -> failwithf "%A" e
+
+module CallHierarchyPrepareParams =
+ let create (uri : DocumentUri) (line : int) (character : int) : CallHierarchyPrepareParams =
+ {
+ TextDocument = { Uri = uri }
+ Position = { Character = character; Line = line }
+ }
+
+module LspRange =
+ let create (startLine : int) (startCharacter : int) (endLine : int) (endCharacter : int) : Range =
+ {
+ Start = { Character = startCharacter; Line = startLine }
+ End = { Character = endCharacter; Line = endLine }
+ }
+
+
+let incomingTests createServer =
+ serverTestList "IncomingTests" createServer defaultConfigDto (Some incomingExamples) (fun server -> [
+ testCaseAsync "Example1" <| async {
+ let! (aDoc, _) = Server.openDocument "Example1.fsx" server
+ use aDoc = aDoc
+ let! server = server
+
+ let prepareParams = CallHierarchyPrepareParams.create aDoc.Uri 2 9
+ let! prepareResult = server.Server.TextDocumentPrepareCallHierarchy prepareParams |> Async.map resultOptionGet
+
+ let expectedPrepareResult : HierarchyItem array = [|
+ {
+ Data = None
+ Detail = None
+ Kind = SymbolKind.Function
+ Name = "bar"
+ Range = LspRange.create 2 8 2 11
+ SelectionRange = LspRange.create 2 8 2 11
+ Tags = None
+ Uri = aDoc.Uri
+ }
+ |]
+
+ Expect.equal prepareResult expectedPrepareResult "prepareResult"
+
+ let expectedIncomingResult : CallHierarchyIncomingCall array =
+ [|
+ {
+ FromRanges = [|
+ LspRange.create 8 12 8 15
+ |]
+ From = {
+ Data = None
+ Detail = Some "From Example1.fsx"
+ Kind = SymbolKind.Function
+ Name = "foo"
+ Range = LspRange.create 6 12 8 18
+ SelectionRange = LspRange.create 6 12 6 15
+ Tags = None
+ Uri = aDoc.Uri
+ }
+ }
+ |]
+
+ let incomingParams : CallHierarchyIncomingCallsParams = {
+ Item = prepareResult[0]
+ }
+ let! incomingResult = server.Server.CallHierarchyIncomingCalls incomingParams |> Async.map resultOptionGet
+
+ Expect.equal incomingResult expectedIncomingResult "incomingResult"
+ }
+ ])
+
+
+let tests createServer =
+ testList "CallHierarchy" [
+ incomingTests createServer
+ ]
diff --git a/test/FsAutoComplete.Tests.Lsp/Program.fs b/test/FsAutoComplete.Tests.Lsp/Program.fs
index b4f4ca435..6a15c271d 100644
--- a/test/FsAutoComplete.Tests.Lsp/Program.fs
+++ b/test/FsAutoComplete.Tests.Lsp/Program.fs
@@ -120,6 +120,7 @@ let lspTests =
DependentFileChecking.tests createServer
UnusedDeclarationsTests.tests createServer
EmptyFileTests.tests createServer
+ CallHierarchy.tests createServer
] ]
/// Tests that do not require a LSP server
diff --git a/test/FsAutoComplete.Tests.Lsp/TestCases/CallHierarchy/IncomingCalls/Example1.fsx b/test/FsAutoComplete.Tests.Lsp/TestCases/CallHierarchy/IncomingCalls/Example1.fsx
new file mode 100644
index 000000000..68785a851
--- /dev/null
+++ b/test/FsAutoComplete.Tests.Lsp/TestCases/CallHierarchy/IncomingCalls/Example1.fsx
@@ -0,0 +1,12 @@
+module Example1 =
+
+ let bar () =
+ printfn "lol"
+
+ let bazz () =
+ let foo () =
+ printfn "lol"
+ bar ()
+ foo ()
+
+ ignore bazz