diff --git a/src/FsAutoComplete.Core/AdaptiveExtensions.fs b/src/FsAutoComplete.Core/AdaptiveExtensions.fs new file mode 100644 index 000000000..2758a5d95 --- /dev/null +++ b/src/FsAutoComplete.Core/AdaptiveExtensions.fs @@ -0,0 +1,290 @@ +namespace FsAutoComplete.Adaptive + +open System +open FSharp.Data.Adaptive +open FSharp.Data.Traceable + +[] +module AdaptiveExtensions = + type ChangeableHashMap<'Key, 'Value> with + + /// + /// Adds the given key and calls the adder function if no previous key exists. + /// Otherwise calls updater with the current key/value and returns a new value to be set. + /// Returns true when the map changed. + /// + member x.AddOrUpdate(key, adder, updater) = + match x.TryGetValue key with + | None -> x.Add(key, adder key) + | Some v -> x.Add(key, updater key v) + + /// + /// Adds the given key and calls the adder function if no previous key exists. + /// Otherwise calls updater with the current key/value but does not override existing value in the map. + /// This is useful when the 'Value is itself a changeable value like a cval, aset, amap which should be changed + /// but the parent container doesn't need to know about those changes itself. + /// + member x.AddOrElse(key, adder, updater) = + match x.TryGetValue key with + | None -> x.Add(key, adder key) |> ignore + | Some v -> updater key v + + +module Utils = + let cheapEqual (a: 'T) (b: 'T) = + ShallowEqualityComparer<'T>.Instance.Equals(a, b) + +/// +/// Maps and calls dispose before mapping of new values. Useful for cleaning up callbacks like AddMarkingCallback for tracing purposes. +/// +type MapDisposableTupleVal<'T1, 'T2, 'Disposable when 'Disposable :> IDisposable> + (mapping: 'T1 -> ('T2 * 'Disposable), input: aval<'T1>) = + inherit AVal.AbstractVal<'T2>() + + let mutable cache: ValueOption = ValueNone + + override x.Compute(token: AdaptiveToken) = + let i = input.GetValue token + + match cache with + | ValueSome(struct (a, b, _)) when Utils.cheapEqual a i -> b + | ValueSome(struct (a, b, c)) -> + (c :> IDisposable).Dispose() + let (b, c) = mapping i + cache <- ValueSome(struct (i, b, c)) + b + | ValueNone -> + let (b, c) = mapping i + cache <- ValueSome(struct (i, b, c)) + b + +module AVal = + let mapOption f = AVal.map (Option.map f) + + /// + /// Maps and calls dispose before mapping of new values. Useful for cleaning up callbacks like AddMarkingCallback for tracing purposes. + /// + let mapDisposableTuple mapper value = + MapDisposableTupleVal(mapper, value) :> aval<_> + + /// + /// Calls a mapping function which creates additional dependencies to be tracked. + /// + let mapWithAdditionalDependenies (mapping: 'a -> 'b * #seq<#IAdaptiveValue>) (value: aval<'a>) : aval<'b> = + let mutable lastDeps = HashSet.empty + + { new AVal.AbstractVal<'b>() with + member x.Compute(token: AdaptiveToken) = + let input = value.GetValue token + + // re-evaluate the mapping based on the (possibly new input) + let result, deps = mapping input + + // compute the change in the additional dependencies and adjust the graph accordingly + let newDeps = HashSet.ofSeq deps + + for op in HashSet.computeDelta lastDeps newDeps do + match op with + | Add(_, d) -> + // the new dependency needs to be evaluated with our token, s.t. we depend on it in the future + d.GetValueUntyped token |> ignore + | Rem(_, d) -> + // we no longer need to depend on the old dependency so we can remove ourselves from its outputs + lock d.Outputs (fun () -> d.Outputs.Remove x) |> ignore + + lastDeps <- newDeps + + result } + :> aval<_> + + /// + /// Creates observables from adaptive values + /// + module Observable = + open System.Reactive.Linq + + /// + /// Creates an observable with the given object and will be executed whenever the object gets marked out-of-date. Note that it does not trigger when the object is currently out-of-date. + /// + /// The aval to get out-of-date information from. + /// An observable + let onWeakMarking (aval: #aval<_>) = + Observable.Create(fun (obs: IObserver) -> aval.AddWeakMarkingCallback(obs.OnNext)) + +module ASet = + /// Creates an amap with the keys from the set and the values given by mapping and + /// adaptively applies the given mapping function to all elements and returns a new amap containing the results. + let mapAtoAMap mapper src = + src |> ASet.mapToAMap mapper |> AMap.mapA (fun _ v -> v) + +module AMap = + open FSharp.Data.Traceable + + /// A simple multi-map implementation. + type internal MultiSetMap<'k, 'v> = HashMap<'k, HashSet<'v>> + + /// A simple multi-map implementation. + module internal MultiSetMap = + [] + let empty<'k, 'v> : MultiSetMap<'k, 'v> = HashMap.empty + + let add (key: 'k) (value: 'v) (m: MultiSetMap<'k, 'v>) : MultiSetMap<'k, 'v> = + m + |> HashMap.alter key (fun old -> + match old with + | Some old -> Some(HashSet.add value old) + | None -> Some(HashSet.single value)) + + let remove (key: 'k) (value: 'v) (m: MultiSetMap<'k, 'v>) : bool * MultiSetMap<'k, 'v> = + let wasLast = ref false + + let result = + m + |> HashMap.alter key (fun old -> + match old with + | None -> None + | Some old -> + let s = HashSet.remove value old + + if HashSet.isEmpty s then + wasLast.Value <- true + None + else + Some s) + + wasLast.Value, result + + let find (key: 'k) (m: MultiSetMap<'k, 'v>) = + match HashMap.tryFind key m with + | Some s -> s + | None -> HashSet.empty + + + /// Reader for batchRecalc operations. + [] + type BatchRecalculateDirty<'k, 'a, 'b>(input: amap<'k, 'a>, mapping: HashMap<'k, 'a> -> HashMap<'k, aval<'b>>) = + inherit AbstractReader>(HashMapDelta.empty) + + let reader = input.GetReader() + do reader.Tag <- "input" + let cacheLock = obj () + let mutable cache: HashMap<'k, aval<'b>> = HashMap.Empty + let mutable targets = MultiSetMap.empty, 'k> + let mutable dirty = HashMap.empty<'k, aval<'b>> + + let consumeDirty () = + lock cacheLock (fun () -> + let d = dirty + dirty <- HashMap.empty + d) + + override x.InputChangedObject(t, o) = +#if FABLE_COMPILER + if isNull o.Tag then + let o = unbox> o + + for i in MultiSetMap.find o targets do + dirty <- HashMap.add i o dirty +#else + match o with + | :? aval<'b> as o -> + lock cacheLock (fun () -> + for i in MultiSetMap.find o targets do + dirty <- HashMap.add i o dirty + + ) + | _ -> () +#endif + + override x.Compute t = + let mutable dirty = consumeDirty () + let old = reader.State + let ops = reader.GetChanges t |> HashMapDelta.toHashMap + + let setOps, removeOps = + ((HashMap.empty, HashMap.empty), ops) + ||> HashMap.fold (fun (sets, rems) i op -> + dirty <- HashMap.remove i dirty + + cache <- + match HashMap.tryRemove i cache with + | Some(o, remaingCache) -> + let rem, rest = MultiSetMap.remove o i targets + targets <- rest + + if rem then + o.Outputs.Remove x |> ignore + + remaingCache + | None -> cache + + match op with + | Set v -> HashMap.add i v sets, rems + | Remove -> sets, HashMap.add i Remove rems) + + + let mutable changes = HashMap.empty + + let setOps = + (setOps, dirty) + ||> HashMap.fold (fun s k _ -> + match HashMap.tryFind k old with + | Some v -> HashMap.add k v s + | None -> s) + + for i, k in mapping setOps do + cache <- HashMap.add i k cache + let v = k.GetValue t + targets <- MultiSetMap.add k i targets + changes <- HashMap.add i (Set v) changes + + HashMap.union removeOps changes |> HashMapDelta + + + /// Adaptively looks up the given key in the map and flattens 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 tryFindAndFlatten (key: 'Key) (map: amap<'Key, aval>>) = + aval { + match! AMap.tryFind key map with + | Some x -> return! x + | None -> return None + } + + /// 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: 'Key) (map: amap<'Key, #aval<'Value>>) = + aval { + match! AMap.tryFind key map with + | Some v -> + let! v2 = v + return Some v2 + | None -> return None + } + + /// Adaptively applies the given mapping function to all elements and returns a new amap containing the results. + let mapAVal + (mapper: 'Key -> 'InValue -> aval<'OutValue>) + (map: #amap<'Key, #aval<'InValue>>) + : amap<'Key, aval<'OutValue>> = + map |> AMap.map (fun k v -> AVal.bind (mapper k) v) + + + /// Adaptively applies the given mapping to all changes and reapplies mapping on dirty outputs + let batchRecalcDirty (mapping: HashMap<'K, 'T1> -> HashMap<'K, aval<'T2>>) (map: amap<'K, 'T1>) = + // if map.IsConstant then + // let map = force map |> mapping + // if map |> HashMap.forall (fun _ v -> v.IsConstant) then + // constant (fun () -> map |> HashMap.map (fun _ v -> AVal.force v)) + // else + // // TODO better impl possible + // create (fun () -> BatchRecalculateDirty(ofHashMap map, id)) + // else + AMap.ofReader (fun () -> BatchRecalculateDirty(map, mapping)) + + let mapWithAdditionalDependenies + (mapping: HashMap<'K, 'T1> -> HashMap<'K, 'T2 * #seq<#IAdaptiveValue>>) + (map: amap<'K, 'T1>) + = + let mapping = + mapping + >> HashMap.map (fun _ v -> AVal.constant v |> AVal.mapWithAdditionalDependenies (id)) + + batchRecalcDirty mapping map diff --git a/src/FsAutoComplete.Core/FsAutoComplete.Core.fsproj b/src/FsAutoComplete.Core/FsAutoComplete.Core.fsproj index a172a1fa2..3f7ea261e 100644 --- a/src/FsAutoComplete.Core/FsAutoComplete.Core.fsproj +++ b/src/FsAutoComplete.Core/FsAutoComplete.Core.fsproj @@ -9,6 +9,7 @@ + @@ -45,4 +46,4 @@ - + \ No newline at end of file diff --git a/src/FsAutoComplete.Core/paket.references b/src/FsAutoComplete.Core/paket.references index 323acb9d2..6512c0971 100644 --- a/src/FsAutoComplete.Core/paket.references +++ b/src/FsAutoComplete.Core/paket.references @@ -7,6 +7,7 @@ System.Configuration.ConfigurationManager FSharp.UMX FsToolkit.ErrorHandling Fantomas.Client +FSharp.Data.Adaptive Ionide.ProjInfo.ProjectSystem System.Reflection.Metadata diff --git a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs index d3b666269..60170afda 100644 --- a/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs +++ b/src/FsAutoComplete/LspServers/AdaptiveFSharpLspServer.fs @@ -16,6 +16,7 @@ open Newtonsoft.Json.Linq open Ionide.ProjInfo.ProjectSystem open System.Reactive open System.Reactive.Linq +open FsAutoComplete.Adaptive open FSharp.Control.Reactive open FsToolkit.ErrorHandling @@ -39,143 +40,6 @@ open FsAutoComplete.LspHelpers open FsAutoComplete.UnionPatternMatchCaseGenerator open System.Collections.Concurrent -[] -module AdaptiveExtensions = - type ChangeableHashMap<'Key, 'Value> with - - /// - /// Adds the given key and calls the adder function if no previous key exists. - /// Otherwise calls updater with the current key/value and returns a new value to be set. - /// Returns true when the map changed. - /// - member x.AddOrUpdate(key, adder, updater) = - match x.TryGetValue key with - | None -> x.Add(key, adder key) - | Some v -> x.Add(key, updater key v) - - /// - /// Adds the given key and calls the adder function if no previous key exists. - /// Otherwise calls updater with the current key/value but does not override existing value in the map. - /// This is useful when the 'Value is itself a changeable value like a cval, aset, amap which should be changed - /// but the parent container doesn't need to know about those changes itself. - /// - member x.AddOrElse(key, adder, updater) = - match x.TryGetValue key with - | None -> x.Add(key, adder key) |> ignore - | Some v -> updater key v - - -module Utils = - let cheapEqual (a: 'T) (b: 'T) = - ShallowEqualityComparer<'T>.Instance.Equals(a, b) - -/// -/// Maps and calls dispose before mapping of new values. Useful for cleaning up callbacks like AddMarkingCallback for tracing purposes. -/// -type MapDisposableTupleVal<'T1, 'T2, 'Disposable when 'Disposable :> IDisposable> - (mapping: 'T1 -> ('T2 * 'Disposable), input: aval<'T1>) = - inherit AVal.AbstractVal<'T2>() - - let mutable cache: ValueOption = ValueNone - - override x.Compute(token: AdaptiveToken) = - let i = input.GetValue token - - match cache with - | ValueSome(struct (a, b, _)) when Utils.cheapEqual a i -> b - | ValueSome(struct (a, b, c)) -> - (c :> IDisposable).Dispose() - let (b, c) = mapping i - cache <- ValueSome(struct (i, b, c)) - b - | ValueNone -> - let (b, c) = mapping i - cache <- ValueSome(struct (i, b, c)) - b - -module AVal = - let mapOption f = AVal.map (Option.map f) - - /// - /// Maps and calls dispose before mapping of new values. Useful for cleaning up callbacks like AddMarkingCallback for tracing purposes. - /// - let mapDisposableTuple mapper value = - MapDisposableTupleVal(mapper, value) :> aval<_> - - /// - /// Calls a mapping function which creates additional dependencies to be tracked. - /// - let mapWithAdditionalDependenies (mapping: 'a -> 'b * #seq<#IAdaptiveValue>) (value: aval<'a>) : aval<'b> = - let mutable lastDeps = HashSet.empty - - { new AVal.AbstractVal<'b>() with - member x.Compute(token: AdaptiveToken) = - let input = value.GetValue token - - // re-evaluate the mapping based on the (possibly new input) - let result, deps = mapping input - - // compute the change in the additional dependencies and adjust the graph accordingly - let newDeps = HashSet.ofSeq deps - - for op in HashSet.computeDelta lastDeps newDeps do - match op with - | Add(_, d) -> - // the new dependency needs to be evaluated with our token, s.t. we depend on it in the future - d.GetValueUntyped token |> ignore - | Rem(_, d) -> - // we no longer need to depend on the old dependency so we can remove ourselves from its outputs - lock d.Outputs (fun () -> d.Outputs.Remove x) |> ignore - - lastDeps <- newDeps - - result } - :> aval<_> - - /// - /// Creates observables from adaptive values - /// - module Observable = - /// - /// Creates an observable with the given object that will be executed whenever the object gets marked out-of-date. Note that it does not trigger when the object is currently out-of-date. - /// - /// The aval to get out-of-date information from. - /// An observable - let onWeakMarking (aval: #aval<_>) = - Observable.Create(fun (obs: IObserver) -> aval.AddWeakMarkingCallback(obs.OnNext)) - -module ASet = - /// Creates an amap with the keys from the set and the values given by mapping and - /// adaptively applies the given mapping function to all elements and returns a new amap containing the results. - let mapAtoAMap mapper src = - src |> ASet.mapToAMap mapper |> AMap.mapA (fun _ v -> v) - -module AMap = - /// Adaptively looks up the given key in the map and flattens 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 tryFindAndFlatten (key: 'Key) (map: amap<'Key, aval>>) = - aval { - match! AMap.tryFind key map with - | Some x -> return! x - | None -> return None - } - - /// 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: 'Key) (map: amap<'Key, #aval<'Value>>) = - aval { - match! AMap.tryFind key map with - | Some v -> - let! v2 = v - return Some v2 - | None -> return None - } - - /// Adaptively applies the given mapping function to all elements and returns a new amap containing the results. - let mapAVal - (mapper: 'Key -> 'InValue -> aval<'OutValue>) - (map: #amap<'Key, #aval<'InValue>>) - : amap<'Key, aval<'OutValue>> = - map |> AMap.map (fun k v -> AVal.bind (mapper k) v) - [] type WorkspaceChosen = | Sln of string // TODO later when ionide supports sending specific choices instead of only fsprojs @@ -187,7 +51,7 @@ type WorkspaceChosen = type AdaptiveWorkspaceChosen = | Sln of aval * DateTime> // TODO later when ionide supports sending specific choices instead of only fsprojs | Directory of aval * DateTime> // TODO later when ionide supports sending specific choices instead of only fsprojs - | Projs of aval, DateTime>> + | Projs of amap, DateTime> | NotChosen type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FSharpLspClient) = @@ -637,14 +501,11 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let cb = aval.AddMarkingCallback(cb) aval |> AVal.mapDisposableTuple (fun x -> x, cb) - let projectFileChanges (filePath: string) = + let projectFileChanges project (filePath: string) = let file = getLastUTCChangeForFile filePath let logMsg () = - logger.info ( - Log.setMessage "Loading projects because of {delta}" - >> Log.addContextDestructured "delta" filePath - ) + logger.info (Log.setMessageI $"Loading {project:project} because of {filePath:filePath}") file |> addAValLogging logMsg @@ -669,12 +530,17 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let workspacePaths: ChangeableValue = cval WorkspaceChosen.NotChosen + let noopDisposable = + { new IDisposable with + member this.Dispose() : unit = () } + let adaptiveWorkspacePaths = workspacePaths |> AVal.map (fun wsp -> match wsp with - | WorkspaceChosen.Sln v -> projectFileChanges v |> AdaptiveWorkspaceChosen.Sln - | WorkspaceChosen.Directory d -> failwith "Need to use AdaptiveDirectory" |> AdaptiveWorkspaceChosen.Directory + | WorkspaceChosen.Sln v -> projectFileChanges v v |> AdaptiveWorkspaceChosen.Sln, noopDisposable + | WorkspaceChosen.Directory d -> + failwith "Need to use AdaptiveDirectory" |> AdaptiveWorkspaceChosen.Directory, noopDisposable | WorkspaceChosen.Projs projs -> let projChanges = projs @@ -688,14 +554,12 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar >> Log.addContextDestructured "delta" delta )) - projChanges - |> AMap.toAVal - |> AVal.mapDisposableTuple (fun x -> x, cb) - |> AdaptiveWorkspaceChosen.Projs + projChanges |> AdaptiveWorkspaceChosen.Projs, cb - | WorkspaceChosen.NotChosen -> AdaptiveWorkspaceChosen.NotChosen + | WorkspaceChosen.NotChosen -> AdaptiveWorkspaceChosen.NotChosen, noopDisposable ) + |> AVal.mapDisposableTuple (id) let clientCapabilities = cval None @@ -704,6 +568,20 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let glyphToSymbolKind = clientCapabilities |> AVal.map glyphToSymbolKindGenerator + let tryFindProp name (props: list) = + match props |> Seq.tryFind (fun x -> x.Name = name) with + | Some v -> v.Value |> Option.ofObj + | None -> None + + let (|ProjectAssetsFile|_|) (props: list) = tryFindProp "ProjectAssetsFile" props + + let (|BaseIntermediateOutputPath|_|) (props: list) = + tryFindProp "BaseIntermediateOutputPath" props + + let (|MSBuildAllProjects|_|) (props: list) = + tryFindProp "MSBuildAllProjects" props + |> Option.map (fun v -> v.Split(';', StringSplitOptions.RemoveEmptyEntries)) + let loadedProjectOptions = aval { let! loader = loader @@ -718,7 +596,7 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar let! projectOptions = projects - |> AVal.mapWithAdditionalDependenies (fun projects -> + |> AMap.mapWithAdditionalDependenies (fun projects -> projects |> Seq.iter (fun (proj: string, _) -> @@ -743,32 +621,36 @@ type AdaptiveFSharpLspServer(workspaceLoader: IWorkspaceLoader, lspClient: FShar >> Log.addContextDestructured "path" p.Properties ) - let additionalDependencies = + let additionalDependencies (p: Types.ProjectOptions) = + [ let projectFileChanges = projectFileChanges p.ProjectFileName + + match p.Properties with + | ProjectAssetsFile v -> yield projectFileChanges (UMX.tag v) + | _ -> () + + let objPath = (|BaseIntermediateOutputPath|_|) p.Properties + + let isWithinObjFolder (file: string) = + match objPath with + | None -> true // if no obj folder provided assume we should track this file + | Some objPath -> file.Contains(objPath) + match p.Properties with + | MSBuildAllProjects v -> + yield! + v + |> Array.filter (fun x -> x.EndsWith(".props") && isWithinObjFolder x) + |> Array.map (UMX.tag >> projectFileChanges) + | _ -> () ] + + HashMap.ofList [ for p in projectOptions do - match p.Properties |> Seq.tryFind (fun x -> x.Name = "ProjectAssetsFile") with - | Some v -> yield projectFileChanges (UMX.tag v.Value) - | None -> () - - let objPath = - p.Properties - |> Seq.tryFind (fun x -> x.Name = "BaseIntermediateOutputPath") - |> Option.map (fun v -> v.Value) - - let isWithinObjFolder (file: string) = - match objPath with - | None -> true // if no obj folder provided assume we should track this file - | Some objPath -> file.Contains(objPath) - - 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 >> projectFileChanges) - | None -> () ] - - projectOptions, additionalDependencies) + %p.ProjectFileName, (p, additionalDependencies p) ] + + ) + |> AMap.toAVal + |> AVal.map HashMap.toValueList + and! checker = checker checker.ClearCaches() // if we got new projects assume we're gonna need to clear caches