From ae90c497c4c1e7a8a0144cd9f6f29fb15fd072e3 Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Mon, 21 Aug 2023 15:33:26 -0500 Subject: [PATCH 1/6] Use default name rather than cryptic error --- src/Elmish.WPF/ViewModels.fs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Elmish.WPF/ViewModels.fs b/src/Elmish.WPF/ViewModels.fs index e881e6b8..946bae9d 100644 --- a/src/Elmish.WPF/ViewModels.fs +++ b/src/Elmish.WPF/ViewModels.fs @@ -254,9 +254,9 @@ type [] ViewModelBase<'model, 'msg>(args: ViewModelArgs<'model member _.Get<'a> ([] ?memberName: string) = fun (binding: string -> Binding<'model, 'msg, 'a>) -> + let name = memberName |> Option.defaultValue "" let result = option { - let! name = memberName let! vmBinding = option { match helper.Bindings.TryGetValue name with | true, value -> @@ -279,22 +279,22 @@ type [] ViewModelBase<'model, 'msg>(args: ViewModelArgs<'model } match result with | None -> - log.LogError("[{BindingNameChain}] Get FAILED: Binding {BindingName} could not be constructed", nameChain, memberName) - failwithf $"[%s{nameChain}] Get FAILED: Binding {memberName} could not be constructed" + log.LogError("[{BindingNameChain}] Get FAILED: Binding {BindingName} could not be constructed", nameChain, name) + failwithf $"[%s{nameChain}] Get FAILED: Binding {name} could not be constructed" | Some (Error e) -> match e with - | GetError.OneWayToSource -> log.LogError("[{BindingNameChain}] Get FAILED: Binding {BindingName} is read-only", nameChain, memberName) - | GetError.SubModelSelectedItem d -> log.LogError("[{BindingNameChain}] Get FAILED: Failed to find an element of the SubModelSeq binding {SubModelSeqBindingName} with ID {ID} in the getter for the binding {BindingName}", d.NameChain, d.SubModelSeqBindingName, d.Id, memberName) - | GetError.ToNullError (ValueOption.ToNullError.ValueCannotBeNull nonNullTypeName) -> log.LogError("[{BindingNameChain}] Get FAILED: Binding {BindingName} is null, but type {Type} is non-nullable", nameChain, memberName, nonNullTypeName) - failwithf $"[%s{nameChain}] Get FAILED: Binding {memberName} returned an error {e}" + | GetError.OneWayToSource -> log.LogError("[{BindingNameChain}] Get FAILED: Binding {BindingName} is set-only", nameChain, name) + | GetError.SubModelSelectedItem d -> log.LogError("[{BindingNameChain}] Get FAILED: Failed to find an element of the SubModelSeq binding {SubModelSeqBindingName} with ID {ID} in the getter for the binding {BindingName}", d.NameChain, d.SubModelSeqBindingName, d.Id, name) + | GetError.ToNullError (ValueOption.ToNullError.ValueCannotBeNull nonNullTypeName) -> log.LogError("[{BindingNameChain}] Get FAILED: Binding {BindingName} is null, but type {Type} is non-nullable", nameChain, name, nonNullTypeName) + failwithf $"[%s{nameChain}] Get FAILED: Binding {name} returned an error {e}" | Some (Ok r) -> r member _.Set<'a> (value: 'a, [] ?memberName: string) = fun (binding: string -> Binding<'model, 'msg, 'a>) -> + let name = memberName |> Option.defaultValue "" try let success = option { - let! name = memberName let! vmBinding = option { match setBindings.TryGetValue name with | true, value -> @@ -308,11 +308,11 @@ type [] ViewModelBase<'model, 'msg>(args: ViewModelArgs<'model return Set(value).Recursive(helper.Model, vmBinding) } if success = Some false then - log.LogError("[{BindingNameChain}] Set FAILED: Binding {BindingName} is read-only", nameChain, memberName) + log.LogError("[{BindingNameChain}] Set FAILED: Binding {BindingName} is read-only", nameChain, name) else if success = None then - log.LogError("[{BindingNameChain}] Set FAILED: Binding {BindingName} could not be constructed", nameChain, memberName) + log.LogError("[{BindingNameChain}] Set FAILED: Binding {BindingName} could not be constructed", nameChain, name) with e -> - log.LogError(e, "[{BindingNameChain}] Set FAILED: Exception thrown while processing binding {BindingName}", nameChain, memberName) + log.LogError(e, "[{BindingNameChain}] Set FAILED: Exception thrown while processing binding {BindingName}", nameChain, name) reraise () interface IViewModel<'model, 'msg> with From 69bcc198e91fdd1a81a857b9eb79c88708352523 Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Mon, 21 Aug 2023 15:35:12 -0500 Subject: [PATCH 2/6] Make so events are raised in setter instead of being deferred --- src/Elmish.WPF/BindingVmHelpers.fs | 54 ++++++++++++++++++++++++------ src/Elmish.WPF/ViewModels.fs | 9 +++++ 2 files changed, 53 insertions(+), 10 deletions(-) diff --git a/src/Elmish.WPF/BindingVmHelpers.fs b/src/Elmish.WPF/BindingVmHelpers.fs index 6123f02e..3791a2e2 100644 --- a/src/Elmish.WPF/BindingVmHelpers.fs +++ b/src/Elmish.WPF/BindingVmHelpers.fs @@ -89,6 +89,8 @@ module Helpers2 = type OneWayBinding<'model, 'a> = { OneWayData: OneWayData<'model, 'a> + GetPending: unit -> 'a voption + SetPending: 'a voption -> unit } type OneWayToSourceBinding<'model, 'a> = { @@ -103,6 +105,8 @@ type OneWaySeqBinding<'model, 'a, 'aCollection, 'id when 'id : equality> = { type TwoWayBinding<'model, 'a> = { Get: 'model -> 'a Set: 'a -> 'model -> unit + GetPending: unit -> 'a voption + SetPending: 'a voption -> unit } type SubModelBinding<'model, 'msg, 'bindingModel, 'bindingMsg, 'vm> = { @@ -217,10 +221,15 @@ and VmBinding<'model, 'msg, 't> = module internal MapOutputType = let private baseCase (fOut: 'a -> 'b) (fIn: 'b -> 'a) (data: BaseVmBinding<'model, 'msg, 'a>) : BaseVmBinding<'model, 'msg, 'b> = match data with - | OneWay b -> OneWay { OneWayData = { Get = b.OneWayData.Get >> fOut } } + | OneWay b -> OneWay { OneWayData = { Get = b.OneWayData.Get >> fOut } + GetPending = b.GetPending >> ValueOption.map fOut + SetPending = ValueOption.map fIn >> b.SetPending } | OneWayToSource b -> OneWayToSource { Set = fIn >> b.Set } | Cmd b -> Cmd b - | TwoWay b -> TwoWay { Get = b.Get >> fOut; Set = fIn >> b.Set } + | TwoWay b -> TwoWay { Get = b.Get >> fOut + Set = fIn >> b.Set + GetPending = b.GetPending >> ValueOption.map fOut + SetPending = ValueOption.map fIn >> b.SetPending } | OneWaySeq b -> OneWaySeq { OneWaySeqData = { Get = b.OneWaySeqData.Get @@ -384,7 +393,10 @@ type Initialize<'t> : BaseVmBinding<'model, 'msg, 't> option = match binding with | OneWayData d -> - { OneWayData = d |> BindingData.OneWay.measureFunctions measure } + let mutable pending = ValueNone + { OneWayData = d |> BindingData.OneWay.measureFunctions measure + GetPending = fun () -> pending + SetPending = (fun v -> pending <- v) } |> OneWay |> Some | OneWayToSourceData d -> @@ -399,8 +411,11 @@ type Initialize<'t> |> Some | TwoWayData d -> let d = d |> BindingData.TwoWay.measureFunctions measure measure + let mutable pending = ValueNone { Get = d.Get - Set = fun obj m -> d.Set obj m |> dispatch } + Set = fun obj m -> d.Set obj m |> dispatch + GetPending = fun () -> pending + SetPending = (fun v -> pending <- v) } |> TwoWay |> Some | CmdData d -> @@ -565,7 +580,7 @@ type Initialize<'t> /// Updates the binding and returns a list indicating what events to raise for this binding -type Update<'t> +type Update<'t when 't : equality> (loggingArgs: LoggingViewModelArgs, name: string) = @@ -577,8 +592,14 @@ type Update<'t> (newModel: 'model, binding: BaseVmBinding<'model, 'msg, 't>) = match binding with - | OneWay _ - | TwoWay _ + | OneWay b -> + let pending = b.GetPending() + b.SetPending ValueNone + if pending.IsSome && pending = ValueSome (b.OneWayData.Get newModel) then [] else [ PropertyChanged name ] + | TwoWay b -> + let pending = b.GetPending() + b.SetPending ValueNone + if pending.IsSome && pending = ValueSome (b.Get newModel) then [] else [ PropertyChanged name ] | SubModelSelectedItem _ -> [ PropertyChanged name ] | OneWayToSource _ -> [] | OneWaySeq b -> @@ -744,8 +765,18 @@ type Get<'t>(nameChain: string) = member _.Base (model: 'model, binding: BaseVmBinding<'model, 'msg, 't>) = match binding with - | OneWay { OneWayData = d } -> d.Get model |> Ok - | TwoWay b -> b.Get model |> Ok + | OneWay b -> + let pending = b.GetPending() + if pending.IsSome then + pending.Value |> Ok + else + b.OneWayData.Get model |> Ok + | TwoWay b -> + let pending = b.GetPending() + if pending.IsSome then + pending.Value |> Ok + else + b.Get model |> Ok | OneWayToSource _ -> GetError.OneWayToSource |> Error | OneWaySeq { Values = vals } -> vals.GetCollection () |> Ok | Cmd cmd -> cmd |> unbox |> Ok @@ -796,6 +827,7 @@ type Set<'t>(value: 't) = match binding with | TwoWay b -> b.Set value model + b.SetPending (ValueSome value) true | OneWayToSource b -> b.Set value model @@ -803,7 +835,9 @@ type Set<'t>(value: 't) = | SubModelSelectedItem b -> b.TypedSet(model, ValueOption.ofNull value) true - | OneWay _ + | OneWay b -> + b.SetPending (ValueSome value) + false | OneWaySeq _ | Cmd _ | SubModel _ diff --git a/src/Elmish.WPF/ViewModels.fs b/src/Elmish.WPF/ViewModels.fs index 946bae9d..4c001434 100644 --- a/src/Elmish.WPF/ViewModels.fs +++ b/src/Elmish.WPF/ViewModels.fs @@ -214,6 +214,7 @@ type [] internal DynamicViewModel<'model, 'msg> let success = Set(value).Recursive(helper.Model, binding) if not success then log.LogError("[{BindingNameChain}] TrySetMember FAILED: Binding {BindingName} is read-only", nameChain, binder.Name) + ViewModelHelper.raiseEvents [UpdateData.PropertyChanged binder.Name] helper success with e -> log.LogError(e, "[{BindingNameChain}] TrySetMember FAILED: Exception thrown while processing binding {BindingName}", nameChain, binder.Name) @@ -295,6 +296,12 @@ type [] ViewModelBase<'model, 'msg>(args: ViewModelArgs<'model try let success = option { + let _ = match helper.Bindings.TryGetValue (name) with + | true, getBinding -> + Set(value).Recursive(helper.Model, getBinding |> MapOutputType.unboxVm) + | false, _ -> + false + let! vmBinding = option { match setBindings.TryGetValue name with | true, value -> @@ -311,6 +318,8 @@ type [] ViewModelBase<'model, 'msg>(args: ViewModelArgs<'model log.LogError("[{BindingNameChain}] Set FAILED: Binding {BindingName} is read-only", nameChain, name) else if success = None then log.LogError("[{BindingNameChain}] Set FAILED: Binding {BindingName} could not be constructed", nameChain, name) + else + ViewModelHelper.raiseEvents [UpdateData.PropertyChanged name] helper with e -> log.LogError(e, "[{BindingNameChain}] Set FAILED: Exception thrown while processing binding {BindingName}", nameChain, name) reraise () From b754327472b72635450c27f5b6cbb6d8579caf4a Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Mon, 21 Aug 2023 15:39:43 -0500 Subject: [PATCH 3/6] Simplify threading handling since we don't need to wait New model schedules jobs quickly but executes them on low priority so that we can combine updates if the UI starts falling behind. program.UpdateViewModel(vm, model) is fully transitive so it's safe to skip intermediate updates as long as we get the last one. --- src/Elmish.WPF/WpfProgram.fs | 53 +++++++++++------------------------- 1 file changed, 16 insertions(+), 37 deletions(-) diff --git a/src/Elmish.WPF/WpfProgram.fs b/src/Elmish.WPF/WpfProgram.fs index 8231fa15..938d53da 100644 --- a/src/Elmish.WPF/WpfProgram.fs +++ b/src/Elmish.WPF/WpfProgram.fs @@ -86,9 +86,7 @@ module WpfProgram = [] type ElmishThreaderBehavior = | SingleThreaded - | Threaded_NoUIDispatch - | Threaded_PendingUIDispatch of pending: System.Threading.Tasks.TaskCompletionSource unit> - | Threaded_UIDispatch of active: System.Threading.Tasks.TaskCompletionSource unit> + | MultiThreaded of nextJob: (unit -> unit) option /// Starts an Elmish dispatch loop, setting the bindings as the DataContext for the /// specified FrameworkElement. Non-blocking. If you have an explicit entry point where @@ -142,33 +140,7 @@ module WpfProgram = if element.Dispatcher = elmishDispatcher then SingleThreaded else - Threaded_NoUIDispatch - - // Dispatch that comes in from a view model message (setter or WPF ICommand). These may come from UI thread, so must be streated specially - let dispatchFromViewModel msg = - if element.Dispatcher = Threading.Dispatcher.CurrentDispatcher then // if the message is from the UI thread - match threader with - | SingleThreaded -> dispatch msg // Dispatch directly if `elmishDispatcher` is the same as the UI thread - | Threaded_NoUIDispatch -> // If `elmishDispatcher` is different, invoke dispatch on it then wait around for it to finish executing, then execute the continuation on the current (UI) thread - let uiWaiter = System.Threading.Tasks.TaskCompletionSource unit>() - threader <- Threaded_PendingUIDispatch uiWaiter - - // This should always leave `threader` in the `Threaded_NoUIDispatch` state before leaving this thread invocation - let synchronizedUiDispatch () = - threader <- Threaded_UIDispatch uiWaiter - dispatch msg - threader <- Threaded_NoUIDispatch - - elmishDispatcher.InvokeAsync(synchronizedUiDispatch) |> ignore - // Wait on `elmishDispatcher` to get to this invocation and collect result - let continuationOnUIThread = uiWaiter.Task.Result - // Result is the `program.UpdateViewModel` call, so execute here on the UI thread - continuationOnUIThread() - | Threaded_PendingUIDispatch uiWaiter - | Threaded_UIDispatch uiWaiter -> - uiWaiter.SetException(exn("Error in core Elmish.WPF threading code. Invalid state reached!")) - else // message is not from the UI thread - elmishDispatcher.InvokeAsync(fun () -> dispatch msg) |> ignore // handle as a command message + MultiThreaded None // Core Elmish calls this from `dispatch`, which means this is always called from `elmishDispatcher` // (which is UI thread in single-threaded case) @@ -177,7 +149,7 @@ module WpfProgram = | None -> // no view model yet, so create one let args = { initialModel = model - dispatch = dispatchFromViewModel + dispatch = fun msg -> elmishDispatcher.InvokeAsync(fun () -> dispatch msg) |> ignore loggingArgs = { performanceLogThresholdMs = program.PerformanceLogThreshold nameChain = "main" @@ -188,12 +160,19 @@ module WpfProgram = viewModel <- Some vm | Some vm -> // view model exists, so update match threader with - | Threaded_UIDispatch uiWaiter -> // We are in the specific dispatch call from the UI thread (see `synchronizedUiDispatch` in `dispatchFromViewModel`) - uiWaiter.SetResult(fun () -> program.UpdateViewModel (vm, model)) // execute `UpdateViewModel` on UI thread - | Threaded_PendingUIDispatch _ -> // We are in a non-UI dispatch that updated the model before the UI got its update in, but after the user interacted - () // Skip updating the UI since the screen is frozen anyways, and `program.UpdateViewModel` is fully transitive - | Threaded_NoUIDispatch -> // We are in a non-UI dispatch with no pending user interactions known - element.Dispatcher.InvokeAsync(fun () -> program.UpdateViewModel (vm, model)) |> ignore // Schedule update normally + | MultiThreaded _ -> + let executeJob () = + match threader with + | MultiThreaded (Some job) -> + job() + threader <- MultiThreaded None + | _ -> + bindingsLogger.LogDebug("Job was empty - No update done.") + let scheduleJob () = + threader <- MultiThreaded (Some (fun () -> program.UpdateViewModel(vm, model))) + element.Dispatcher.InvokeAsync(executeJob, Threading.DispatcherPriority.Background) |> ignore // Schedule update normally + + element.Dispatcher.InvokeAsync(scheduleJob, Threading.DispatcherPriority.Normal) |> ignore | SingleThreaded -> // If we aren't using different threads, always process normally element.Dispatcher.Invoke(fun () -> program.UpdateViewModel (vm, model)) From 58e0699369bc65e7603d32f070714d45c4aff462 Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Mon, 21 Aug 2023 15:45:50 -0500 Subject: [PATCH 4/6] Add some explanatory comments --- src/Elmish.WPF/WpfProgram.fs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Elmish.WPF/WpfProgram.fs b/src/Elmish.WPF/WpfProgram.fs index 938d53da..cf5ec326 100644 --- a/src/Elmish.WPF/WpfProgram.fs +++ b/src/Elmish.WPF/WpfProgram.fs @@ -163,16 +163,18 @@ module WpfProgram = | MultiThreaded _ -> let executeJob () = match threader with - | MultiThreaded (Some job) -> + | MultiThreaded (Some job) -> // Execute current job, not job that was originally scheduled job() threader <- MultiThreaded None - | _ -> + | MultiThreaded None -> // If another executor beat us to the job, do nothing bindingsLogger.LogDebug("Job was empty - No update done.") + | SingleThreaded -> + bindingsLogger.LogError("Error in core Elmish.WPF code - impossible state reached.") let scheduleJob () = - threader <- MultiThreaded (Some (fun () -> program.UpdateViewModel(vm, model))) - element.Dispatcher.InvokeAsync(executeJob, Threading.DispatcherPriority.Background) |> ignore // Schedule update normally + threader <- MultiThreaded (Some (fun () -> program.UpdateViewModel(vm, model))) // Update current job so it preempts any pending jobs + element.Dispatcher.InvokeAsync(executeJob, Threading.DispatcherPriority.Background) |> ignore // Execute update at low priority - element.Dispatcher.InvokeAsync(scheduleJob, Threading.DispatcherPriority.Normal) |> ignore + element.Dispatcher.InvokeAsync(scheduleJob, Threading.DispatcherPriority.Normal) |> ignore // Schedule update at normal priority | SingleThreaded -> // If we aren't using different threads, always process normally element.Dispatcher.Invoke(fun () -> program.UpdateViewModel (vm, model)) From 43205831ec64b3a810a95bf168b33a2f5b87c9fc Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Mon, 21 Aug 2023 16:03:46 -0500 Subject: [PATCH 5/6] Bump version to beta-51 --- src/Elmish.WPF/Elmish.WPF.fsproj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Elmish.WPF/Elmish.WPF.fsproj b/src/Elmish.WPF/Elmish.WPF.fsproj index bdae1788..76736f46 100644 --- a/src/Elmish.WPF/Elmish.WPF.fsproj +++ b/src/Elmish.WPF/Elmish.WPF.fsproj @@ -18,7 +18,7 @@ https://github.com/elmish/Elmish.WPF WPF F# fsharp Elmish Elm elmish-wpf-logo-128x128.png - 4.0.0-beta-50 + 4.0.0-beta-51 https://github.com/elmish/Elmish.WPF/blob/master/RELEASE_NOTES.md $(OtherFlags) --warnon:1182 From 705008d2e3cbf94f5f6777b82981e1909cda9c1b Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Mon, 21 Aug 2023 16:09:39 -0500 Subject: [PATCH 6/6] Add release notes for beta-51 --- RELEASE_NOTES.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md index c366a6b4..1df11f74 100644 --- a/RELEASE_NOTES.md +++ b/RELEASE_NOTES.md @@ -1,3 +1,7 @@ +#### 4.0.0-beta-51 +* Allow skipping intermediate updates when they pile up on UI Thread. +* Notify Property Changed directly on Set rather than waiting around for the next update. Set value is now cached until the next time update/dispatch is called. + #### 4.0.0-beta-50 * Upgraded to Elmish v4 * **BREAKING:** Changed syntax of `WpfProgram.withSubscription` to now take named list of `Subscribe<'msg> = Dispatch<'msg> -> IDisposable` (note the `IDisposable` return). This function now gets called every time `'model` updates (previously it was only called on startup). This allows starting and stopping of subscriptions from this function by the given string list identifier.