Improve threading behavior

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.

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,14 +827,17 @@ 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
         true
     | SubModelSelectedItem b ->
         b.TypedSet(model, ValueOption.ofNull value)
         true
-    | OneWay _
+    | OneWay b ->
+        b.SetPending (ValueSome value)
+        false
     | OneWaySeq _
     | Cmd _
     | SubModel _

src/Elmish.WPF/Elmish.WPF.fsproj

@@ -18,7 +18,7 @@
     <PackageProjectUrl>https://github.com/elmish/Elmish.WPF</PackageProjectUrl>
     <PackageTags>WPF F# fsharp Elmish Elm</PackageTags>
     <PackageIcon>elmish-wpf-logo-128x128.png</PackageIcon>
-    <Version>4.0.0-beta-50</Version>
+    <Version>4.0.0-beta-51</Version>
     <PackageReleaseNotes>https://github.com/elmish/Elmish.WPF/blob/master/RELEASE_NOTES.md</PackageReleaseNotes>
     <!--Turn on warnings for unused values (arguments and let bindings) -->
     <OtherFlags>$(OtherFlags) --warnon:1182</OtherFlags>

src/Elmish.WPF/ViewModels.fs

@@ -214,6 +214,7 @@ type [<AllowNullLiteral>] 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)
@@ -254,9 +255,9 @@ type [<AllowNullLiteral>] ViewModelBase<'model, 'msg>(args: ViewModelArgs<'model
 
   member _.Get<'a> ([<CallerMemberName>] ?memberName: string) =
     fun (binding: string -> Binding<'model, 'msg, 'a>) ->
+      let name = memberName |> Option.defaultValue "<unset memberName>"
       let result =
         option {
-          let! name = memberName
           let! vmBinding = option {
             match helper.Bindings.TryGetValue name with
             | true, value ->
@@ -279,22 +280,28 @@ type [<AllowNullLiteral>] 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, [<CallerMemberName>] ?memberName: string) =
     fun (binding: string -> Binding<'model, 'msg, 'a>) ->
+      let name = memberName |> Option.defaultValue "<unset memberName>"
       try
         let success =
           option {
-            let! name = memberName
+            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 ->
@@ -308,11 +315,13 @@ type [<AllowNullLiteral>] 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)
+        else
+          ViewModelHelper.raiseEvents [UpdateData.PropertyChanged name] helper
       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

src/Elmish.WPF/WpfProgram.fs

@@ -86,9 +86,7 @@ module WpfProgram =
   [<Struct>]
   type ElmishThreaderBehavior =
   | SingleThreaded
-  | Threaded_NoUIDispatch
-  | Threaded_PendingUIDispatch of pending: System.Threading.Tasks.TaskCompletionSource<unit -> unit>
-  | Threaded_UIDispatch of active: System.Threading.Tasks.TaskCompletionSource<unit -> unit>
+  | MultiThreaded of nextJob: (unit -> unit) option
 
   /// <summary>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 -> 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,21 @@ 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) -> // 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))) // 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 // Schedule update at normal priority
           | SingleThreaded -> // If we aren't using different threads, always process normally
             element.Dispatcher.Invoke(fun () -> program.UpdateViewModel (vm, model))