Merge pull request #1063 from fabulous-dev/debounce-cmd

Debounce cmd

Author: TimLariviere

.config/dotnet-tools.json

@@ -3,7 +3,7 @@
   "isRoot": true,
   "tools": {
     "fantomas": {
-      "version": "5.2.0",
+      "version": "6.2.3",
       "commands": [
         "fantomas"
       ]

.github/workflows/pull_request.yml

@@ -18,7 +18,7 @@ jobs:
     - name: Check code formatting
       run: |
         dotnet tool restore
-        dotnet fantomas --check -r src
+        dotnet fantomas --check src
     - name: Restore
       run: dotnet restore ${SLN_FILE}
     - name: Build

src/Fabulous.Tests/CmdTests.fs

@@ -0,0 +1,43 @@
+namespace Fabulous.Tests
+
+open Fabulous
+open NUnit.Framework
+
+type CmdTestsMsg = NewValue of int
+
+module CmdTestsHelper =
+    let execute dispatch (cmd: Cmd<'msg>) =
+        for sub in cmd do
+            sub dispatch
+
+[<TestFixture>]
+type ``Cmd tests``() =
+    [<Test>]
+    member _.``Cmd.debounce only dispatch the last message``() =
+        async {
+            let mutable actualValue = None
+
+            let dispatch msg =
+                if actualValue.IsNone then
+                    actualValue <- Some msg
+
+            let triggerCmd = Cmd.debounce 100 NewValue
+
+            triggerCmd 1 |> CmdTestsHelper.execute dispatch
+            do! Async.Sleep 50
+            triggerCmd 2 |> CmdTestsHelper.execute dispatch
+            do! Async.Sleep 75
+            triggerCmd 3 |> CmdTestsHelper.execute dispatch
+            do! Async.Sleep 125
+
+            Assert.AreEqual(Some(NewValue 3), actualValue)
+
+            actualValue <- None
+
+            triggerCmd 4 |> CmdTestsHelper.execute dispatch
+            do! Async.Sleep 75
+            triggerCmd 5 |> CmdTestsHelper.execute dispatch
+            do! Async.Sleep 125
+
+            Assert.AreEqual(Some(NewValue 5), actualValue)
+        }

src/Fabulous.Tests/Fabulous.Tests.fsproj

@@ -15,6 +15,7 @@
     <Compile Include="AttributesTests.fs" />
     <Compile Include="ViewTests.fs" />
     <Compile Include="ArrayTests.fs" />
+    <Compile Include="CmdTests.fs" />
   </ItemGroup>
   <ItemGroup>
     <PackageReference Include="BenchmarkDotNet" />

src/Fabulous/Builders.fs

@@ -38,9 +38,9 @@ type WidgetBuilder<'msg, 'marker> =
               DebugName = $"{typeof<'marker>.Name}<{typeof<'msg>.Name}>"
 #endif
               ScalarAttributes =
-                  match StackList.length &scalarAttributes with
-                  | 0us -> ValueNone
-                  | _ -> ValueSome(Array.sortInPlace (fun a -> a.Key) (StackList.toArray &scalarAttributes))
+                match StackList.length &scalarAttributes with
+                | 0us -> ValueNone
+                | _ -> ValueSome(Array.sortInPlace (fun a -> a.Key) (StackList.toArray &scalarAttributes))
 
               WidgetAttributes = ValueOption.map (Array.sortInPlace(fun a -> a.Key)) widgetAttributes
 

src/Fabulous/Cmd.fs

@@ -1,5 +1,6 @@
 namespace Fabulous
 
+open System.Threading
 open System.Threading.Tasks
 
 /// Dispatch - feed new message into the processing loop
@@ -104,3 +105,26 @@ module Cmd =
                       dispatch(failure ex)
               }
               |> ignore ]
+
+    /// Command to issue a message if no other message has been issued within the specified timeout
+    let debounce (timeout: int) (fn: 'value -> 'msg) : 'value -> Cmd<'msg> =
+        let mutable cts: CancellationTokenSource = null
+
+        fun (value: 'value) ->
+            [ fun dispatch ->
+                  if cts <> null then
+                      cts.Cancel()
+                      cts.Dispose()
+
+                  cts <- new CancellationTokenSource()
+
+                  Async.Start(
+                      async {
+                          do! Async.Sleep(timeout)
+                          dispatch(fn value)
+
+                          cts.Dispose()
+                          cts <- null
+                      },
+                      cts.Token
+                  ) ]