diff --git a/vsintegration/src/FSharp.ProjectSystem.Base/Project/OutputGroup.cs b/vsintegration/src/FSharp.ProjectSystem.Base/Project/OutputGroup.cs index 64026b6164b..2523d89427a 100644 --- a/vsintegration/src/FSharp.ProjectSystem.Base/Project/OutputGroup.cs +++ b/vsintegration/src/FSharp.ProjectSystem.Base/Project/OutputGroup.cs @@ -113,7 +113,7 @@ public virtual void Refresh() var result = new BuildResult(MSBuildResult.Failed, null); if (project.ProjectMgr.BuildProject.Targets.ContainsKey(ProjectFileConstants.AllProjectOutputGroups)) { - result = project.InvokeMsBuild(ProjectFileConstants.AllProjectOutputGroups, false /*isBeingCalledByComputeSourcesAndFlags*/); + result = project.InvokeMsBuild(ProjectFileConstants.AllProjectOutputGroups); if (!result.IsSuccessful) { // we could not compute it, probably because there is a real build going on right now diff --git a/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectNode.cs b/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectNode.cs index 7807479b415..69c33594227 100644 --- a/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectNode.cs +++ b/vsintegration/src/FSharp.ProjectSystem.Base/Project/ProjectNode.cs @@ -2268,7 +2268,7 @@ public string GetBuildMacroValue(string propertyName) { this.SetCurrentConfiguration(); this.UpdateMSBuildState(); - var result = this.InvokeMsBuild(ProjectFileConstants.AllProjectOutputGroups, false); + var result = this.InvokeMsBuild(ProjectFileConstants.AllProjectOutputGroups); if (result.ProjectInstance != null) return result.ProjectInstance.GetPropertyValue(propertyName); }; return this.GetProjectProperty(propertyName, true); @@ -2947,9 +2947,7 @@ public virtual void Reload() this.ProcessCustomBuildActions(); this.ProcessFilesAndFolders(); - - - + this.LoadNonBuildInformation(); this.InitSccInfo(); @@ -3142,11 +3140,6 @@ internal virtual void SetBuildConfigurationProperties(ConfigCanonicalName config /// Result from executing the target (success/failure) [SuppressMessage("Microsoft.Naming", "CA1709:IdentifiersShouldBeCasedCorrectly", MessageId = "Ms")] internal virtual BuildResult InvokeMsBuild(string target, IEnumerable> extraProperties = null) - { - return InvokeMsBuild(target, false, extraProperties); - } - - internal virtual BuildResult InvokeMsBuild(string target, bool isBeingCalledByComputeSourcesAndFlags, IEnumerable> extraProperties = null) { UIThread.MustBeCalledFromUIThread(); ProjectInstance projectInstance = null; @@ -3156,10 +3149,6 @@ internal virtual BuildResult InvokeMsBuild(string target, bool isBeingCalledByCo if (submission != null) { MSBuildResult result = (submission.BuildResult.OverallResult == BuildResultCode.Success) ? MSBuildResult.Successful : MSBuildResult.Failed; - if (!isBeingCalledByComputeSourcesAndFlags) - { - this.ComputeSourcesAndFlags(); - } return new BuildResult(result, projectInstance); } else diff --git a/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs b/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs index 732758bac64..b62e5fe3068 100644 --- a/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs +++ b/vsintegration/src/FSharp.ProjectSystem.FSharp/Project.fs @@ -440,6 +440,7 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem let mutable updateSolnEventsHandle = 0u let mutable updateSolnEventsHandle2 = 0u let mutable updateSolnEventsHandle3 = 0u + let mutable updateSolnEventsHandle4 = 0u let mutable trackProjectRetargetingCookie = 0u @@ -586,14 +587,26 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem let listener = new SolutionEventsListener(this) let buildMgr = this.Site.GetService(typeof) :?> IVsSolutionBuildManager + if updateSolnEventsHandle <> 0u then + buildMgr.UnadviseUpdateSolutionEvents(updateSolnEventsHandle) |> ignore buildMgr.AdviseUpdateSolutionEvents((listener :> IVsUpdateSolutionEvents), &updateSolnEventsHandle) |> ignore let buildMgr2 = this.Site.GetService(typeof) :?> IVsSolutionBuildManager2 + if updateSolnEventsHandle2 <> 0u then + buildMgr2.UnadviseUpdateSolutionEvents(updateSolnEventsHandle2) |> ignore buildMgr2.AdviseUpdateSolutionEvents((listener :> IVsUpdateSolutionEvents2), &updateSolnEventsHandle2) |> ignore let buildMgr3 = this.Site.GetService(typeof) :?> IVsSolutionBuildManager3 + if updateSolnEventsHandle3 <> 0u then + buildMgr3.UnadviseUpdateSolutionEvents3(updateSolnEventsHandle3) |> ignore buildMgr3.AdviseUpdateSolutionEvents3((listener :> IVsUpdateSolutionEvents3), &updateSolnEventsHandle3) |> ignore + let buildMgr5 = this.Site.GetService(typeof) :?> IVsSolutionBuildManager5 + if updateSolnEventsHandle4 <> 0u then + buildMgr5.UnadviseUpdateSolutionEvents4(updateSolnEventsHandle4) |> ignore + buildMgr5.AdviseUpdateSolutionEvents4((listener :> IVsUpdateSolutionEvents4), &updateSolnEventsHandle4) |> ignore // Register for project retargeting events let sTrackProjectRetargeting = this.Site.GetService(typeof) :?> IVsTrackProjectRetargeting + if trackProjectRetargetingCookie <> 0u then + sTrackProjectRetargeting.UnadviseTrackProjectRetargetingEvents(trackProjectRetargetingCookie) |> ignore sTrackProjectRetargeting.AdviseTrackProjectRetargetingEvents((listener :> IVsTrackProjectRetargetingEvents), &trackProjectRetargetingCookie) |> ignore isInCommandLineMode <- @@ -616,6 +629,8 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem buildMgr2.UnadviseUpdateSolutionEvents(updateSolnEventsHandle2) |> ignore let buildMgr3 = this.Site.GetService(typeof) :?> IVsSolutionBuildManager3 buildMgr3.UnadviseUpdateSolutionEvents3(updateSolnEventsHandle3) |> ignore + let buildMgr5 = this.Site.GetService(typeof) :?> IVsSolutionBuildManager5 + buildMgr5.UnadviseUpdateSolutionEvents4(updateSolnEventsHandle4) |> ignore let documentTracker = this.Site.GetService(typeof) :?> IVsTrackProjectDocuments2 documentTracker.UnadviseTrackProjectDocumentsEvents(trackDocumentsHandle) |> ignore @@ -1328,12 +1343,27 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem yield System.IO.Path.GetFullPath(System.IO.Path.Combine(projectFolder, i.EvaluatedInclude)) |] member x.GetCompileItems() = let sources,_ = sourcesAndFlags.Value in sources - member x.GetCompileFlags() = let _,flags = sourcesAndFlags.Value in flags + member x.GetCompileFlags() = let _,flags = sourcesAndFlags.Value in flags override x.ComputeSourcesAndFlags() = + if x.IsInBatchUpdate || box x.BuildProject = null then () else if not(inMidstOfReloading) && not(VsBuildManagerAccessorExtensionMethods.IsInProgress(accessor)) then + + use waitDialog = + { + WaitCaption = FSharpSR.GetString FSharpSR.ProductName + WaitMessage = FSharpSR.GetString FSharpSR.ComputingSourcesAndFlags + ProgressText = Some x.ProjectFile + StatusBmpAnim = null + StatusBarText = None + DelayToShowDialogSecs = 1 + IsCancelable = false + ShowMarqueeProgress = true + } + |> WaitDialog.start x.Site + // REVIEW CompilerFlags will be stale since last 'save' of MSBuild .fsproj file - can we do better? try actuallyBuild <- false @@ -1357,10 +1387,11 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem // If property is not set - msbuild will resolve only primary dependencies, // and compiler will be very unhappy when during processing of referenced assembly it will discover that all fundamental types should be // taken from System.Runtime that is not supplied - let _ = x.InvokeMsBuild("Compile", isBeingCalledByComputeSourcesAndFlags = true, extraProperties = [KeyValuePair("_ResolveReferenceDependencies", "true")]) + + let _ = x.InvokeMsBuild("Compile", extraProperties = [KeyValuePair("_ResolveReferenceDependencies", "true")]) sourcesAndFlagsNotifier.Notify() finally - actuallyBuild <- true + actuallyBuild <- true member internal x.DetermineRuntimeAndSKU(targetFrameworkMoniker : string) = let frameworkName = new System.Runtime.Versioning.FrameworkName(targetFrameworkMoniker) @@ -1439,7 +1470,7 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem member ips.DescriptionOfProject() = let sources,flags = sourcesAndFlags.Value sprintf "Project System: flags(%A) sources:\n%A" flags sources - member ips.CompilerFlags() = let _,flags = sourcesAndFlags.Value in flags + member ips.CompilerFlags() = x.GetCompileFlags() member ips.ProjectFileName() = MSBuildProject.GetFullPath(x.BuildProject) member ips.ErrorListTaskProvider() = Some(x.TaskProvider) member ips.ErrorListTaskReporter() = Some(x.TaskReporter) @@ -1595,6 +1626,11 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem member x.SetSpecificEditorProperty(_mkDocument:string, _propid:int, _value:obj ) = VSConstants.E_NOTIMPL end + + type internal ActiveCfgBatchUpdateState = + | NonBatch + | BatchWaiting + | BatchDone // Why is this a separate class, rather than an interface implemented on // FSharpProjectNode? Because, at the time of initial registration of this @@ -1605,7 +1641,14 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem // class means we have a separate object to CCW wrap, avoiding the problematic // "double CCW-wrapping" of the same object. type internal SolutionEventsListener(projNode) = - let mutable queuedWork : option> = None + + let mutable waitDialog : IDisposable option = None + + // During batch active project configuration changes, make sure we only run CSAF once + // per batch. Before this change, OnActiveProjectCfgChange was being called twice per + // batch per project. + let mutable batchState = NonBatch + // The CCW wrapper seems to prevent an object-identity test, so we determine whether // two IVsHierarchy objects are equal by comparing their captions. (It's ok if this // occasionally yields false positives, as this just means we may do a little extra @@ -1620,14 +1663,16 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem o :?> System.String else null : System.String + let OnActiveProjectCfgChange(pIVsHierarchy) = - if GetCaption(pIVsHierarchy) = GetCaption(projNode.InteropSafeIVsHierarchy) then + if GetCaption(pIVsHierarchy) = GetCaption(projNode.InteropSafeIVsHierarchy) && batchState <> BatchDone then projNode.SetProjectFileDirty(projNode.IsProjectFileDirty) - projNode.ComputeSourcesAndFlags() // REVIEW: It looks like ComputeSourcesAndFlags is called twice. Once on this line and then again because it is added to 'queuedWork' below. - match queuedWork with - | Some(l) -> queuedWork <- Some( projNode :: l ) - | None -> () + projNode.ComputeSourcesAndFlags() + + if batchState = BatchWaiting then + batchState <- BatchDone VSConstants.S_OK + let UpdateConfig(pHierProj) = // By default, the F# project system keeps its own internal Configuration and Platform in sync with the current active // Configuration and Platform by listening for OnActiveProjectCfgChange events. However there is one case where the @@ -1640,6 +1685,7 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem MSBuildProject.SetGlobalProperty(projNode.BuildProject, ProjectFileConstants.Configuration, currentConfigName.ConfigName) MSBuildProject.SetGlobalProperty(projNode.BuildProject, ProjectFileConstants.Platform, currentConfigName.MSBuildPlatform) projNode.UpdateMSBuildState() + interface IVsUpdateSolutionEvents with member x.UpdateSolution_Begin(pfCancelUpdate) = VSConstants.S_OK @@ -1651,6 +1697,7 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem VSConstants.S_OK member x.OnActiveProjectCfgChange(pIVsHierarchy) = OnActiveProjectCfgChange(pIVsHierarchy) + interface IVsUpdateSolutionEvents2 with member x.UpdateSolution_Begin(pfCancelUpdate) = VSConstants.S_OK @@ -1668,17 +1715,51 @@ namespace rec Microsoft.VisualStudio.FSharp.ProjectSystem member x.UpdateProjectCfg_Done(pHierProj, _pCfgProj, _pCfgSln, _dwAction, _fSuccess, _fCancel) = UpdateConfig(pHierProj) VSConstants.S_OK + interface IVsUpdateSolutionEvents3 with member x.OnBeforeActiveSolutionCfgChange(_oldCfg, _newCfg) = - queuedWork <- Some( [] ) + // this will be called for each project, but wait dialogs cannot 'stack' + // i.e. if a wait dialog is already open, subsequent calls to StartWaitDialog + // will not override the current open dialog + waitDialog <- + { + WaitCaption = FSharpSR.GetString FSharpSR.ProductName + WaitMessage = FSharpSR.GetString FSharpSR.UpdatingSolutionConfiguration + ProgressText = None + StatusBmpAnim = null + StatusBarText = None + DelayToShowDialogSecs = 1 + IsCancelable = false + ShowMarqueeProgress = true + } + |> WaitDialog.start projNode.Site + |> Some + VSConstants.S_OK + member x.OnAfterActiveSolutionCfgChange(_oldCfg, _newCfg) = - match queuedWork with - | Some(l) -> l |> List.iter (fun projNode -> projNode.ComputeSourcesAndFlags()) + match waitDialog with + | Some x -> + x.Dispose() + waitDialog <- None | None -> () - queuedWork <- None VSConstants.S_OK - + + interface IVsUpdateSolutionEvents4 with + member x.OnActiveProjectCfgChangeBatchBegin() = + batchState <- BatchWaiting + member x.OnActiveProjectCfgChangeBatchEnd() = + batchState <- NonBatch + member x.UpdateSolution_BeginFirstUpdateAction() = + () + member x.UpdateSolution_BeginUpdateAction(_dwAction) = + () + member x.UpdateSolution_EndLastUpdateAction() = + () + member x.UpdateSolution_EndUpdateAction(_dwAction) = + () + member x.UpdateSolution_QueryDelayFirstUpdateAction(_pfDelay) = + () interface IVsTrackProjectRetargetingEvents with override this.OnRetargetingBeforeChange diff --git a/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectPrelude.fs b/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectPrelude.fs index 2bd6381d081..8a831237ae6 100644 --- a/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectPrelude.fs +++ b/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectPrelude.fs @@ -158,6 +158,8 @@ namespace Microsoft.VisualStudio.FSharp.ProjectSystem [] let OutputTypeDescription = "OutputTypeDescription" [] + let ProductName = "ProductName" + [] let Project = "Project" [] let ProjectFile = "ProjectFile" @@ -215,6 +217,10 @@ namespace Microsoft.VisualStudio.FSharp.ProjectSystem let AddReferenceAssemblyPageDialogNoItemsText = "AddReferenceAssemblyPageDialogNoItemsText"; [] let FSharpCoreVersionIsNotLegacyCompatible = "FSharpCoreVersionIsNotLegacyCompatible"; + [] + let ComputingSourcesAndFlags = "ComputingSourcesAndFlags" + [] + let UpdatingSolutionConfiguration = "UpdatingSolutionConfiguration" type private TypeInThisAssembly = class end diff --git a/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectSystem.fsproj b/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectSystem.fsproj index dbf207a65b2..5b8b21224fa 100644 --- a/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectSystem.fsproj +++ b/vsintegration/src/FSharp.ProjectSystem.FSharp/ProjectSystem.fsproj @@ -52,6 +52,7 @@ + diff --git a/vsintegration/src/FSharp.ProjectSystem.FSharp/VSPackage.resx b/vsintegration/src/FSharp.ProjectSystem.FSharp/VSPackage.resx index 98484ba7692..35e43fc8385 100644 --- a/vsintegration/src/FSharp.ProjectSystem.FSharp/VSPackage.resx +++ b/vsintegration/src/FSharp.ProjectSystem.FSharp/VSPackage.resx @@ -206,13 +206,13 @@ Build - + - + - + @@ -517,11 +517,17 @@ The project will be retargeted, and its targeted frameworks will be reduced. - + All of the Framework assemblies are already referenced. Please use the Object Browser to explore the references in the Framework. Referencing this version of FSharp.Core will cause your project to be incompatible with older versions of Visual Studio. Do you want to continue? - + + Updating compilation sources and flags... + + + Updating solution configuration... + + \ No newline at end of file diff --git a/vsintegration/src/FSharp.ProjectSystem.FSharp/WaitDialog.fs b/vsintegration/src/FSharp.ProjectSystem.FSharp/WaitDialog.fs new file mode 100644 index 00000000000..ea79dde3695 --- /dev/null +++ b/vsintegration/src/FSharp.ProjectSystem.FSharp/WaitDialog.fs @@ -0,0 +1,44 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +namespace Microsoft.VisualStudio.FSharp.ProjectSystem + +open System +open System.Runtime.InteropServices +open Microsoft.VisualStudio.Shell.Interop + +type internal WaitDialogOptions = + { + WaitCaption : string + WaitMessage : string + ProgressText : string option + StatusBmpAnim : obj + StatusBarText : string option + DelayToShowDialogSecs : int + IsCancelable : bool + ShowMarqueeProgress : bool + } + +module internal WaitDialog = + + let start (sp : IServiceProvider) (options : WaitDialogOptions) = + let waitDialogFactory = sp.GetService(typeof) :?> IVsThreadedWaitDialogFactory + let waitDialog = ref null + waitDialogFactory.CreateInstance waitDialog |> Marshal.ThrowExceptionForHR + + waitDialog.Value.StartWaitDialog( + szWaitCaption = options.WaitCaption, + szWaitMessage = options.WaitMessage, + szProgressText = Option.toObj options.ProgressText, + varStatusBmpAnim = options.StatusBmpAnim, + szStatusBarText = Option.toObj options.StatusBarText, + iDelayToShowDialog = options.DelayToShowDialogSecs, + fIsCancelable = options.IsCancelable, + fShowMarqueeProgress = options.ShowMarqueeProgress + ) + |> Marshal.ThrowExceptionForHR + + { new IDisposable with + override __.Dispose () = + let cancelled = ref 0 + waitDialog.Value.EndWaitDialog cancelled |> Marshal.ThrowExceptionForHR + } \ No newline at end of file diff --git a/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj b/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj index 57291e05efe..f3fb19de5e6 100644 --- a/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj +++ b/vsintegration/tests/Salsa/VisualFSharp.Salsa.fsproj @@ -32,6 +32,9 @@ + + False + diff --git a/vsintegration/tests/Salsa/VsMocks.fs b/vsintegration/tests/Salsa/VsMocks.fs index 577de5c5100..3a26098b112 100644 --- a/vsintegration/tests/Salsa/VsMocks.fs +++ b/vsintegration/tests/Salsa/VsMocks.fs @@ -1441,6 +1441,7 @@ module internal VsMocks = let add1, remove1, enumerate1 = mkEventsStorage() let add2, remove2, _ = mkEventsStorage() + let add4, remove4, _ = mkEventsStorage() let configDict = new Dictionary() let configChangeNotifier(h : IVsHierarchy, s : string) = if configDict.ContainsKey(h) then @@ -1517,8 +1518,30 @@ module internal VsMocks = member x.QueryBuildManagerBusyEx(a) = err(__LINE__) member x.UnadviseUpdateSolutionEvents3(a) = 0 + interface IVsSolutionBuildManager5 with + member x.AdviseUpdateSolutionEvents4(pIVsUpdateSolutionEvents, pdwCookie) = + pdwCookie <- add4 pIVsUpdateSolutionEvents + member x.AdviseUpdateSolutionEventsAsync(a,b) = err(__LINE__) |> ignore + member x.FindActiveProjectCfgName(a,b) = err(__LINE__) + member x.UnadviseUpdateSolutionEventsAsync(a) = err(__LINE__) |> ignore + member x.UnadviseUpdateSolutionEvents4(dwCookie) = + remove4 dwCookie } vsSolutionBuildManager, configChangeNotifier + + let vsThreadedWaitDialogFactory = + { new IVsThreadedWaitDialogFactory with + override x.CreateInstance(vsThreadedWaitDialog) = + vsThreadedWaitDialog <- + { new IVsThreadedWaitDialog2 with + override x.EndWaitDialog(_) = 0 + override x.HasCanceled(_) = 0 + override x.StartWaitDialog(_, _, _, _, _, _, _, _) = 0 + override x.StartWaitDialogWithPercentageProgress(_, _, _, _, _, _, _, _, _) = 0 + override x.UpdateProgress(_, _, _, _, _, _, _) = 0 + } + 0 + } let MakeMockServiceProviderAndConfigChangeNotifierNoTargetFrameworkAssembliesService() = let vsSolutionBuildManager, configChangeNotifier = MakeVsSolutionBuildManagerAndConfigChangeNotifier() @@ -1538,6 +1561,7 @@ module internal VsMocks = sp.AddService(typeof, box vsRunningDocumentTable, false) sp.AddService(typeof, box (MockVsBuildManagerAccessor()), false) sp.AddService(typeof, box vsTrackProjectRetargeting, false) + sp.AddService(typeof, box vsThreadedWaitDialogFactory, false) sp, configChangeNotifier let MakeMockServiceProviderAndConfigChangeNotifier20() = diff --git a/vsintegration/tests/unittests/TestLib.ProjectSystem.fs b/vsintegration/tests/unittests/TestLib.ProjectSystem.fs index fdc63df5b56..337a36c31e2 100644 --- a/vsintegration/tests/unittests/TestLib.ProjectSystem.fs +++ b/vsintegration/tests/unittests/TestLib.ProjectSystem.fs @@ -145,8 +145,12 @@ type TheTests() = MSBuildProject.SetGlobalProperty(project.BuildProject, "UTF8Output", forceUTF8) project with - | e -> project.Close() |> ignore - reraise() + | e -> + try + project.Close() |> ignore + with closeExc -> + raise <| AggregateException("An exception occurred during cleanup after a project creation failure", [e; closeExc]) + reraise() static member internal CreateProject(filename : string) = let sp, configChangeNotifier = VsMocks.MakeMockServiceProviderAndConfigChangeNotifier()