From f9584146a7e2008e2756dd57fd7ff1e3a415612a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Timoth=C3=A9=20Larivi=C3=A8re?= Date: Tue, 30 Jan 2024 16:30:54 +0100 Subject: [PATCH 1/5] Add support for disposable components --- src/Fabulous/Cmd.fs | 263 +++++++++++++++++++++---------- src/Fabulous/Component.fs | 30 ++-- src/Fabulous/ComponentContext.fs | 18 ++- src/Fabulous/Fabulous.fsproj | 1 + src/Fabulous/IViewNode.fs | 3 +- src/Fabulous/MvuComponent.fs | 20 +-- src/Fabulous/Program.fs | 20 +-- src/Fabulous/Runner.fs | 74 ++++++--- src/Fabulous/Sub.fs | 90 +++++++++++ 9 files changed, 385 insertions(+), 134 deletions(-) create mode 100644 src/Fabulous/Sub.fs diff --git a/src/Fabulous/Cmd.fs b/src/Fabulous/Cmd.fs index d1a8b19e7..59cc36980 100644 --- a/src/Fabulous/Cmd.fs +++ b/src/Fabulous/Cmd.fs @@ -7,104 +7,205 @@ open System.Threading.Tasks type Dispatch<'msg> = 'msg -> unit /// Subscription - return immediately, but may schedule dispatch of a message at any time -type Sub<'msg> = Dispatch<'msg> -> unit +type Effect<'msg> = Dispatch<'msg> -> unit -/// Cmd - container for subscriptions that may produce messages -type Cmd<'msg> = Sub<'msg> list +/// Cmd - container for effects that may produce messages +type Cmd<'msg> = Effect<'msg> list /// Cmd module for creating and manipulating commands [] module Cmd = + /// Execute the commands using the supplied dispatcher + let internal exec onError (dispatch: Dispatch<'msg>) (cmd: Cmd<'msg>) = + cmd |> List.iter (fun call -> try call dispatch with ex -> onError ex) + /// None - no commands, also known as `[]` let none: Cmd<'msg> = [] - /// Command to issue a specific message - let ofMsg (msg: 'msg) : Cmd<'msg> = [ fun dispatch -> dispatch msg ] - - /// Command to issue a specific message, only when Option.IsSome = true - let ofMsgOption (msg: 'msg option) : Cmd<'msg> = - [ fun dispatch -> - match msg with - | None -> () - | Some msg -> dispatch msg ] - /// When emitting the message, map to another type let map (f: 'a -> 'msg) (cmd: Cmd<'a>) : Cmd<'msg> = cmd |> List.map(fun g -> (fun dispatch -> f >> dispatch) >> g) /// Aggregate multiple commands - let batch (cmds: #seq>) : Cmd<'msg> = cmds |> List.concat - - /// Command to call the subscriber - let ofSub (sub: Sub<'msg>) : Cmd<'msg> = [ sub ] + let batch (cmds: Cmd<'msg> list) : Cmd<'msg> = List.concat cmds - let dispatch d (cmd: Cmd<_>) = - for sub in cmd do - sub d + /// Command to call the effect + let ofEffect (effect: Effect<'msg>) : Cmd<'msg> = [ effect ] - /// Command to issue a message at the end of an asynchronous task - let ofAsyncMsg (p: Async<'msg>) : Cmd<'msg> = - [ fun dispatch -> - async { - let! msg = p - dispatch msg - } - |> Async.StartImmediate ] - - /// Command to issue a message at the end of an asynchronous task, only when Option.IsSome = true - let ofAsyncMsgOption (p: Async<'msg option>) : Cmd<'msg> = - [ fun dispatch -> - async { - let! msg = p - - match msg with - | None -> () - | Some msg -> dispatch msg - } - |> Async.StartImmediate ] + /// Command to issue a specific message + let ofMsg (msg: 'msg) : Cmd<'msg> = [ fun dispatch -> dispatch msg ] - /// Command to issue a message ot the end of an asynchronous task returning a Result - let ofAsyncResult (p: Async>) (success: 'data -> 'msg) (error: 'exn -> 'msg) (failure: exn -> 'msg) : Cmd<'msg> = - [ fun dispatch -> - async { - try - let! result = p - - match result with - | Ok x -> dispatch(success x) - | Error x -> dispatch(error x) - with ex -> - dispatch(failure ex) - } - |> Async.StartImmediate ] - - /// Command to issue a message at the end of an asynchronous task - let ofTaskMsg (p: Task<'msg>) : Cmd<'msg> = - [ fun dispatch -> - task { - try - let! result = p - dispatch result - with _ex -> - // TODO: log exception - () - } - |> ignore ] - - /// Command to issue a message at the end of an asynchronous task - let ofTaskResult (p: Task>) (success: 'data -> 'msg) (error: 'exn -> 'msg) (failure: exn -> 'msg) : Cmd<'msg> = + /// Command to issue a specific message, only when Option.IsSome = true + let ofMsgOption (msg: 'msg option) : Cmd<'msg> = [ fun dispatch -> - task { - try - let! result = p - - match result with - | Ok x -> dispatch(success x) - | Error x -> dispatch(error x) - with ex -> - dispatch(failure ex) - } - |> ignore ] + match msg with + | None -> () + | Some msg -> dispatch msg ] + + module OfFunc = + /// Command to evaluate a simple function and map the result + /// into success or error (of exception) + let either (task: 'a -> _) (arg: 'a) (ofSuccess: _ -> 'msg) (ofError: _ -> 'msg) : Cmd<'msg> = + let bind dispatch = + try + task arg + |> (ofSuccess >> dispatch) + with x -> + x |> (ofError >> dispatch) + [bind] + + /// Command to evaluate a simple function and map the success to a message + /// discarding any possible error + let perform (task: 'a -> _) (arg: 'a) (ofSuccess: _ -> 'msg) : Cmd<'msg> = + let bind dispatch = + try + task arg + |> (ofSuccess >> dispatch) + with x -> + () + [bind] + + /// Command to evaluate a simple function and map the error (in case of exception) + let attempt (task: 'a -> unit) (arg: 'a) (ofError: _ -> 'msg) : Cmd<'msg> = + let bind dispatch = + try + task arg + with x -> + x |> (ofError >> dispatch) + [bind] + + module OfAsyncWith = + /// Command that will evaluate an async block and map the result + /// into success or error (of exception) + let either (start: Async -> unit) + (task: 'a -> Async<_>) + (arg: 'a) + (ofSuccess: _ -> 'msg) + (ofError: _ -> 'msg) : Cmd<'msg> = + let bind dispatch = + async { + let! r = task arg |> Async.Catch + dispatch (match r with + | Choice1Of2 x -> ofSuccess x + | Choice2Of2 x -> ofError x) + } + [bind >> start] + + /// Command that will evaluate an async block and map the success + let perform (start: Async -> unit) + (task: 'a -> Async<_>) + (arg: 'a) + (ofSuccess: _ -> 'msg) : Cmd<'msg> = + let bind dispatch = + async { + let! r = task arg |> Async.Catch + match r with + | Choice1Of2 x -> dispatch (ofSuccess x) + | _ -> () + } + [bind >> start] + + /// Command that will evaluate an async block and map the error (of exception) + let attempt (start: Async -> unit) + (task: 'a -> Async<_>) + (arg: 'a) + (ofError: _ -> 'msg) : Cmd<'msg> = + let bind dispatch = + async { + let! r = task arg |> Async.Catch + match r with + | Choice2Of2 x -> dispatch (ofError x) + | _ -> () + } + [bind >> start] + + /// Command that will evaluate an async block and map the success + let performOption (start: Async -> unit) + (task: 'a -> Async<_ option>) + (arg: 'a) + (ofSuccess: _ -> 'msg) : Cmd<'msg> = + let bind dispatch = + async { + let! r = task arg + match r with + | Some x -> dispatch (ofSuccess x) + | None -> () + } + [bind >> start] + + module OfAsync = + /// Command that will evaluate an async block and map the result + /// into success or error (of exception) + let inline either (task: 'a -> Async<_>) + (arg: 'a) + (ofSuccess: _ -> 'msg) + (ofError: _ -> 'msg) : Cmd<'msg> = + OfAsyncWith.either Async.Start task arg ofSuccess ofError + + /// Command that will evaluate an async block and map the success + let inline perform (task: 'a -> Async<_>) + (arg: 'a) + (ofSuccess: _ -> 'msg) : Cmd<'msg> = + OfAsyncWith.perform Async.Start task arg ofSuccess + + /// Command that will evaluate an async block and map the error (of exception) + let inline attempt (task: 'a -> Async<_>) + (arg: 'a) + (ofError: _ -> 'msg) : Cmd<'msg> = + OfAsyncWith.attempt Async.Start task arg ofError + + let inline msg (task: Async<'msg>) = + OfAsyncWith.perform Async.Start (fun () -> task) () id + + let inline msgOption (task: Async<'msg option>) = + OfAsyncWith.performOption Async.Start (fun () -> task) () id + + module OfAsyncImmediate = + /// Command that will evaluate an async block and map the result + /// into success or error (of exception) + let inline either (task: 'a -> Async<_>) + (arg: 'a) + (ofSuccess: _ -> 'msg) + (ofError: _ -> 'msg) : Cmd<'msg> = + OfAsyncWith.either Async.StartImmediate task arg ofSuccess ofError + + /// Command that will evaluate an async block and map the success + let inline perform (task: 'a -> Async<_>) + (arg: 'a) + (ofSuccess: _ -> 'msg) : Cmd<'msg> = + OfAsyncWith.perform Async.StartImmediate task arg ofSuccess + + /// Command that will evaluate an async block and map the error (of exception) + let inline attempt (task: 'a -> Async<_>) + (arg: 'a) + (ofError: _ -> 'msg) : Cmd<'msg> = + OfAsyncWith.attempt Async.StartImmediate task arg ofError + + module OfTask = + /// Command to call a task and map the results + let inline either (task: 'a -> Task<_>) + (arg:'a) + (ofSuccess: _ -> 'msg) + (ofError: _ -> 'msg) : Cmd<'msg> = + OfAsync.either (task >> Async.AwaitTask) arg ofSuccess ofError + + /// Command to call a task and map the success + let inline perform (task: 'a -> Task<_>) + (arg:'a) + (ofSuccess: _ -> 'msg) : Cmd<'msg> = + OfAsync.perform (task >> Async.AwaitTask) arg ofSuccess + + /// Command to call a task and map the error + let inline attempt (task: 'a -> #Task) + (arg:'a) + (ofError: _ -> 'msg) : Cmd<'msg> = + OfAsync.attempt (task >> Async.AwaitTask) arg ofError + + let inline msg (task: Task<'msg>) = + OfAsync.msg (task |> Async.AwaitTask) + + let inline msgOption (task: Task<'msg option>) = + OfAsync.msgOption (task |> Async.AwaitTask) /// 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> = diff --git a/src/Fabulous/Component.fs b/src/Fabulous/Component.fs index 1b0c4646d..3e0e356a1 100644 --- a/src/Fabulous/Component.fs +++ b/src/Fabulous/Component.fs @@ -216,12 +216,6 @@ type Component(treeContext: ViewTreeContext, body: ComponentBody, context: Compo let mutable _view = null let mutable _contextSubscription: IDisposable = null - interface IDisposable with - member this.Dispose() = - if _contextSubscription <> null then - _contextSubscription.Dispose() - _contextSubscription <- null - member private this.MergeAttributes(rootWidget: Widget, componentWidgetOpt: Widget voption) = match componentWidgetOpt with | ValueNone -> struct (rootWidget.ScalarAttributes, rootWidget.WidgetAttributes, rootWidget.WidgetCollectionAttributes) @@ -321,6 +315,22 @@ type Component(treeContext: ViewTreeContext, body: ComponentBody, context: Compo let viewNode = treeContext.GetViewNode _view Reconciler.update treeContext.CanReuseView (ValueSome prevRootWidget) currRootWidget viewNode + + member this.Dispose() = + if _contextSubscription <> null then + _contextSubscription.Dispose() + + if _context <> null then + _context.Dispose() + + _body <- null + _widget <- Unchecked.defaultof<_> + _view <- null + _contextSubscription <- null + _context <- null + + interface IDisposable with + member this.Dispose() = this.Dispose() member this.Render() = treeContext.SyncAction(this.RenderInternal) @@ -343,11 +353,11 @@ module Component = | Some attr -> attr.Value :?> ComponentData | None -> failwith "Component widget must have a body" - let ctx = ComponentContext() + let ctx = new ComponentContext() let comp = new Component(treeContext, data.Body, ctx) let struct (node, view) = comp.CreateView(ValueSome widget) - // TODO: Attach component to view so component is not discarded by GC + treeContext.SetComponent view comp struct (node, view) AttachView = @@ -360,11 +370,11 @@ module Component = | Some attr -> attr.Value :?> ComponentData | None -> failwith "Component widget must have a body" - let ctx = ComponentContext() + let ctx = new ComponentContext() let comp = new Component(treeContext, data.Body, ctx) let node = comp.AttachView(widget, view) - // TODO: Attach component to view so component is not discarded by GC + treeContext.SetComponent view comp node } diff --git a/src/Fabulous/ComponentContext.fs b/src/Fabulous/ComponentContext.fs index ca2dc05e3..4600bb406 100644 --- a/src/Fabulous/ComponentContext.fs +++ b/src/Fabulous/ComponentContext.fs @@ -1,5 +1,6 @@ namespace Fabulous +open System open System.ComponentModel (* @@ -18,6 +19,7 @@ we can leverage the inlining capabilities of the ComponentBuilder to create an a /// /// Holds the values for the various states of a component. /// +[] type ComponentContext(initialSize: int) = static let mutable nextId = 0 @@ -27,11 +29,12 @@ type ComponentContext(initialSize: int) = let id = getNextId() let mutable values = Array.zeroCreate initialSize + let disposables = System.Collections.Generic.List() let renderNeeded = Event() // We assume that most components will have few values, so initialize it with a small array - new() = ComponentContext(3) + new() = new ComponentContext(3) member this.Id = id @@ -64,6 +67,19 @@ type ComponentContext(initialSize: int) = member this.SetValue(key: int, value: 'T) = this.SetValueInternal(key, value) this.NeedsRender() + + member this.LinkDisposable(disposable: IDisposable) = + disposables.Add(disposable) + + member this.Dispose() = + for disposable in disposables do + disposable.Dispose() + disposables.Clear() + + values <- Array.empty + + interface IDisposable with + member this.Dispose() = this.Dispose() [] type Context private () = diff --git a/src/Fabulous/Fabulous.fsproj b/src/Fabulous/Fabulous.fsproj index 73572af2d..e5e292729 100644 --- a/src/Fabulous/Fabulous.fsproj +++ b/src/Fabulous/Fabulous.fsproj @@ -33,6 +33,7 @@ + diff --git a/src/Fabulous/IViewNode.fs b/src/Fabulous/IViewNode.fs index 13db986ed..cdd9884dc 100644 --- a/src/Fabulous/IViewNode.fs +++ b/src/Fabulous/IViewNode.fs @@ -36,7 +36,8 @@ type ViewTreeContext = Logger: Logger Dispatch: obj -> unit SyncAction: (unit -> unit) -> unit - GetComponent: obj -> obj } + GetComponent: obj -> obj + SetComponent: obj -> obj -> unit } and IViewNode = /// The view that is being rendered diff --git a/src/Fabulous/MvuComponent.fs b/src/Fabulous/MvuComponent.fs index d4d8fdc63..6add37c07 100644 --- a/src/Fabulous/MvuComponent.fs +++ b/src/Fabulous/MvuComponent.fs @@ -26,10 +26,10 @@ module MvuComponent = | Some attr -> attr.Value :?> MvuComponentData | None -> failwith "Component widget must have a body" - let ctx = ComponentContext(1) + let ctx = new ComponentContext(1) - let runner = - Runner((fun () -> ctx.TryGetValue(0).Value), (fun v -> ctx.SetValue(0, v)), data.Program) + let runner = new Runner((fun () -> ctx.TryGetValue(0).Value), (fun v -> ctx.SetValue(0, v)), data.Program) + ctx.LinkDisposable(runner) runner.Start(data.Arg) @@ -38,10 +38,10 @@ module MvuComponent = { treeContext with Dispatch = runner.Dispatch } - let comp = new Component(treeContext, data.Body, ctx) + let comp = new Component(treeContext, data.Body, ctx) let struct (node, view) = comp.CreateView(ValueSome widget) - // TODO: Attach component to view so component is not discarded by GC + treeContext.SetComponent view comp struct (node, view) AttachView = @@ -54,10 +54,10 @@ module MvuComponent = | Some attr -> attr.Value :?> MvuComponentData | None -> failwith "Component widget must have a body" - let ctx = ComponentContext(1) + let ctx = new ComponentContext(1) - let runner = - Runner((fun () -> ctx.TryGetValue(0).Value), (fun v -> ctx.SetValue(0, v)), data.Program) + let runner = new Runner((fun () -> ctx.TryGetValue(0).Value), (fun v -> ctx.SetValue(0, v)), data.Program) + ctx.LinkDisposable(runner) runner.Start(data.Arg) @@ -69,7 +69,7 @@ module MvuComponent = let comp = new Component(treeContext, data.Body, ctx) let node = comp.AttachView(widget, view) - // TODO: Attach component to view so component is not discarded by GC + treeContext.SetComponent view comp node } @@ -93,7 +93,7 @@ type MvuComponentBuilder<'arg, 'msg, 'model, 'marker, 'parentMsg> = let program: Program = { Init = fun arg -> let model, cmd = program.Init(unbox arg) in (box model, Cmd.map box cmd) Update = fun (msg, model) -> let model, cmd = program.Update(unbox msg, unbox model) in (box model, Cmd.map box cmd) - Subscribe = fun model -> Cmd.map box (program.Subscribe(unbox model)) + Subscribe = fun model -> Sub.map "mvu" box (program.Subscribe(unbox model)) Logger = program.Logger ExceptionHandler = program.ExceptionHandler } diff --git a/src/Fabulous/Program.fs b/src/Fabulous/Program.fs index 069314b37..7389f5e06 100644 --- a/src/Fabulous/Program.fs +++ b/src/Fabulous/Program.fs @@ -11,7 +11,7 @@ type Program<'arg, 'model, 'msg> = /// Update the application state based on a message Update: 'msg * 'model -> 'model * Cmd<'msg> /// Add a subscription that can dispatch messages - Subscribe: 'model -> Cmd<'msg> + Subscribe: 'model -> Sub<'msg> /// Configuration for logging all output messages from Fabulous Logger: Logger /// Exception handler for all uncaught exceptions happening in the MVU loop. @@ -54,7 +54,7 @@ module Program = let inline private define (init: 'arg -> 'model * Cmd<'msg>) (update: 'msg -> 'model -> 'model * Cmd<'msg>) = { Init = init Update = (fun (msg, model) -> update msg model) - Subscribe = fun _ -> Cmd.none + Subscribe = fun _ -> Sub.none Logger = ProgramDefaults.defaultLogger() ExceptionHandler = ProgramDefaults.defaultExceptionHandler } @@ -70,13 +70,15 @@ module Program = let mapCmds cmdMsgs = cmdMsgs |> List.map mapCmd |> Cmd.batch define (fun arg -> let m, c = init arg in m, mapCmds c) (fun msg model -> let m, c = update msg model in m, mapCmds c) - /// Subscribe to external source of events. - /// The subscription is called once - with the initial model, but can dispatch new messages at any time. - let withSubscription (subscribe: 'model -> Cmd<'msg>) (program: Program<'arg, 'model, 'msg>) = - let sub model = - Cmd.batch [ program.Subscribe model; subscribe model ] - - { program with Subscribe = sub } + /// Subscribe to external source of events, overrides existing subscription. + /// Return the subscriptions that should be active based on the current model. + /// Subscriptions will be started or stopped automatically to match. + let withSubscription (subscribe: 'model -> Sub<'msg>) (program: Program<'arg, 'model, 'msg>) = + { program with Subscribe = subscribe } + + /// Map existing subscription to external source of events. + let mapSubscription map (program: Program<'arg, 'model, 'msg>) = + { program with Subscribe = map program.Subscribe } /// Configure how the output messages from Fabulous will be handled let withLogger (logger: Logger) (program: Program<'arg, 'model, 'msg>) = { program with Logger = logger } diff --git a/src/Fabulous/Runner.fs b/src/Fabulous/Runner.fs index a5cb3f86c..0e5a8bf3c 100644 --- a/src/Fabulous/Runner.fs +++ b/src/Fabulous/Runner.fs @@ -1,5 +1,6 @@ namespace Fabulous +open System open System.Collections.Concurrent // Runners are responsible for the Model-Update part of MVU. @@ -7,8 +8,35 @@ open System.Collections.Concurrent /// Create a new Runner handling the update loop for the component type Runner<'arg, 'model, 'msg>(getState: unit -> 'model, setState: 'model -> unit, program: Program<'arg, 'model, 'msg>) = + let mutable _activeSubs = Sub.Internal.empty let mutable _reentering = false let queue = ConcurrentQueue<'msg>() + + let onError (message, exn) = + let ex = Exception(message, exn) + if not(program.ExceptionHandler ex) then + raise ex + + let processMsgs dispatch msg = + let mutable lastMsg = ValueSome msg + + while lastMsg.IsSome do + let model = getState() + let newModel, cmd = program.Update(lastMsg.Value, model) + let subs = program.Subscribe(newModel) + + setState newModel + + _activeSubs <- + Sub.Internal.diff _activeSubs subs + |> Sub.Internal.Fx.change onError dispatch + + Cmd.exec (fun ex -> onError("Error updating", ex)) dispatch cmd + + lastMsg <- + match queue.TryDequeue() with + | false, _ -> ValueNone + | true, msg -> ValueSome msg let rec dispatch msg = try @@ -16,42 +44,41 @@ type Runner<'arg, 'model, 'msg>(getState: unit -> 'model, setState: 'model -> un queue.Enqueue(msg) else _reentering <- true - - let mutable lastMsg = ValueSome msg - - while lastMsg.IsSome do - let model = getState() - let newModel, cmd = program.Update(lastMsg.Value, model) - setState newModel - - for sub in cmd do - sub dispatch - - lastMsg <- - match queue.TryDequeue() with - | false, _ -> ValueNone - | true, msg -> ValueSome msg - + processMsgs dispatch msg _reentering <- false with ex -> _reentering <- false - if not(program.ExceptionHandler ex) then reraise() let start arg = try + _reentering <- true + let model, cmd = program.Init(arg) setState model + // Start the subscriptions let subs = program.Subscribe(model) + _activeSubs <- + Sub.Internal.diff _activeSubs subs + |> Sub.Internal.Fx.change onError dispatch - for sub in subs do - sub dispatch - - for sub in cmd do - sub dispatch + // Execute the commands + Cmd.exec (fun ex -> onError("Error initializing", ex)) dispatch cmd + + _reentering <- false with ex -> + _reentering <- false + if not(program.ExceptionHandler(ex)) then + reraise() + + let stop () = + try + _reentering <- true + Sub.Internal.Fx.stop onError _activeSubs + with ex -> + _reentering <- false if not(program.ExceptionHandler(ex)) then reraise() @@ -60,3 +87,6 @@ type Runner<'arg, 'model, 'msg>(getState: unit -> 'model, setState: 'model -> un /// Dispatch a message to the Runner loop member _.Dispatch(msg) = dispatch msg + + interface IDisposable with + member _.Dispose() = stop () \ No newline at end of file diff --git a/src/Fabulous/Sub.fs b/src/Fabulous/Sub.fs new file mode 100644 index 000000000..147d38f02 --- /dev/null +++ b/src/Fabulous/Sub.fs @@ -0,0 +1,90 @@ +namespace Fabulous + +open System + +/// SubId - Subscription ID, alias for string list +type SubId = string list + +/// Subscribe - Starts a subscription, returns IDisposable to stop it +type Subscribe<'msg> = Dispatch<'msg> -> IDisposable + +/// Subscription - Generates new messages when running +type Sub<'msg> = (SubId * Subscribe<'msg>) list + +module Sub = + + /// None - no subscriptions, also known as `[]` + let none : Sub<'msg> = + [] + + /// Aggregate multiple subscriptions + let batch (subs: Sub<'msg> list) : Sub<'msg> = + List.concat subs + + /// When emitting the message, map to another type. + /// To avoid ID conflicts with other components, scope SubIds with a prefix. + let map (idPrefix: string) (f: 'a -> 'msg) (sub: Sub<'a>) : Sub<'msg> = + sub |> List.map (fun (subId, subscribe) -> + idPrefix :: subId, + fun dispatch -> subscribe (f >> dispatch)) + + module Internal = + + module SubId = + + let toString (subId: SubId) = + String.Join("/", subId) + + module Fx = + + let warnDupe onError subId = + let ex = exn "Duplicate SubId" + onError ("Duplicate SubId: " + SubId.toString subId, ex) + + let tryStop onError (subId, sub: IDisposable) = + try + sub.Dispose() + with ex -> + onError ("Error stopping subscription: " + SubId.toString subId, ex) + + let tryStart onError dispatch (subId, start) : (SubId * IDisposable) option = + try + Some (subId, start dispatch) + with ex -> + onError ("Error starting subscription: " + SubId.toString subId, ex) + None + + let stop onError subs = + subs |> List.iter (tryStop onError) + + let change onError dispatch (dupes, toStop, toKeep, toStart) = + dupes |> List.iter (warnDupe onError) + toStop |> List.iter (tryStop onError) + let started = toStart |> List.choose (tryStart onError dispatch) + List.append toKeep started + + module NewSubs = + + let (_dupes, _newKeys, _newSubs) as init = + List.empty, Set.empty, List.empty + + let update (subId, start) (dupes, newKeys, newSubs) = + if Set.contains subId newKeys then + subId :: dupes, newKeys, newSubs + else + dupes, Set.add subId newKeys, (subId, start) :: newSubs + + let calculate subs = + List.foldBack update subs init + + let empty = List.empty + + let diff (activeSubs: (SubId * IDisposable) list) (sub: Sub<'msg>) = + let keys = activeSubs |> List.map fst |> Set.ofList + let dupes, newKeys, newSubs = NewSubs.calculate sub + if keys = newKeys then + dupes, [], activeSubs, [] + else + let toKeep, toStop = activeSubs |> List.partition (fun (k, _) -> Set.contains k newKeys) + let toStart = newSubs |> List.filter (fun (k, _) -> not (Set.contains k keys)) + dupes, toStop, toKeep, toStart \ No newline at end of file From c4967dc14ae24f3253b41eef46a327055279b00e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Timoth=C3=A9=20Larivi=C3=A8re?= Date: Tue, 30 Jan 2024 16:32:24 +0100 Subject: [PATCH 2/5] Format code --- src/Fabulous/Cmd.fs | 129 +++++++++++++------------------ src/Fabulous/Component.fs | 6 +- src/Fabulous/ComponentContext.fs | 12 +-- src/Fabulous/MvuComponent.fs | 10 ++- src/Fabulous/Program.fs | 8 +- src/Fabulous/Runner.fs | 32 ++++---- src/Fabulous/Sub.fs | 46 +++++------ 7 files changed, 112 insertions(+), 131 deletions(-) diff --git a/src/Fabulous/Cmd.fs b/src/Fabulous/Cmd.fs index 59cc36980..2c01fb7ad 100644 --- a/src/Fabulous/Cmd.fs +++ b/src/Fabulous/Cmd.fs @@ -17,8 +17,13 @@ type Cmd<'msg> = Effect<'msg> list module Cmd = /// Execute the commands using the supplied dispatcher let internal exec onError (dispatch: Dispatch<'msg>) (cmd: Cmd<'msg>) = - cmd |> List.iter (fun call -> try call dispatch with ex -> onError ex) - + cmd + |> List.iter(fun call -> + try + call dispatch + with ex -> + onError ex) + /// None - no commands, also known as `[]` let none: Cmd<'msg> = [] @@ -41,29 +46,29 @@ module Cmd = match msg with | None -> () | Some msg -> dispatch msg ] - + module OfFunc = /// Command to evaluate a simple function and map the result /// into success or error (of exception) let either (task: 'a -> _) (arg: 'a) (ofSuccess: _ -> 'msg) (ofError: _ -> 'msg) : Cmd<'msg> = let bind dispatch = try - task arg - |> (ofSuccess >> dispatch) + task arg |> (ofSuccess >> dispatch) with x -> x |> (ofError >> dispatch) - [bind] + + [ bind ] /// Command to evaluate a simple function and map the success to a message /// discarding any possible error let perform (task: 'a -> _) (arg: 'a) (ofSuccess: _ -> 'msg) : Cmd<'msg> = let bind dispatch = try - task arg - |> (ofSuccess >> dispatch) + task arg |> (ofSuccess >> dispatch) with x -> () - [bind] + + [ bind ] /// Command to evaluate a simple function and map the error (in case of exception) let attempt (task: 'a -> unit) (arg: 'a) (ofError: _ -> 'msg) : Cmd<'msg> = @@ -72,140 +77,116 @@ module Cmd = task arg with x -> x |> (ofError >> dispatch) - [bind] + + [ bind ] module OfAsyncWith = /// Command that will evaluate an async block and map the result /// into success or error (of exception) - let either (start: Async -> unit) - (task: 'a -> Async<_>) - (arg: 'a) - (ofSuccess: _ -> 'msg) - (ofError: _ -> 'msg) : Cmd<'msg> = + let either (start: Async -> unit) (task: 'a -> Async<_>) (arg: 'a) (ofSuccess: _ -> 'msg) (ofError: _ -> 'msg) : Cmd<'msg> = let bind dispatch = async { let! r = task arg |> Async.Catch - dispatch (match r with - | Choice1Of2 x -> ofSuccess x - | Choice2Of2 x -> ofError x) + + dispatch( + match r with + | Choice1Of2 x -> ofSuccess x + | Choice2Of2 x -> ofError x + ) } - [bind >> start] + + [ bind >> start ] /// Command that will evaluate an async block and map the success - let perform (start: Async -> unit) - (task: 'a -> Async<_>) - (arg: 'a) - (ofSuccess: _ -> 'msg) : Cmd<'msg> = + let perform (start: Async -> unit) (task: 'a -> Async<_>) (arg: 'a) (ofSuccess: _ -> 'msg) : Cmd<'msg> = let bind dispatch = async { let! r = task arg |> Async.Catch + match r with - | Choice1Of2 x -> dispatch (ofSuccess x) + | Choice1Of2 x -> dispatch(ofSuccess x) | _ -> () } - [bind >> start] + + [ bind >> start ] /// Command that will evaluate an async block and map the error (of exception) - let attempt (start: Async -> unit) - (task: 'a -> Async<_>) - (arg: 'a) - (ofError: _ -> 'msg) : Cmd<'msg> = + let attempt (start: Async -> unit) (task: 'a -> Async<_>) (arg: 'a) (ofError: _ -> 'msg) : Cmd<'msg> = let bind dispatch = async { let! r = task arg |> Async.Catch + match r with - | Choice2Of2 x -> dispatch (ofError x) + | Choice2Of2 x -> dispatch(ofError x) | _ -> () } - [bind >> start] + + [ bind >> start ] /// Command that will evaluate an async block and map the success - let performOption (start: Async -> unit) - (task: 'a -> Async<_ option>) - (arg: 'a) - (ofSuccess: _ -> 'msg) : Cmd<'msg> = + let performOption (start: Async -> unit) (task: 'a -> Async<_ option>) (arg: 'a) (ofSuccess: _ -> 'msg) : Cmd<'msg> = let bind dispatch = async { let! r = task arg + match r with - | Some x -> dispatch (ofSuccess x) + | Some x -> dispatch(ofSuccess x) | None -> () } - [bind >> start] + + [ bind >> start ] module OfAsync = /// Command that will evaluate an async block and map the result /// into success or error (of exception) - let inline either (task: 'a -> Async<_>) - (arg: 'a) - (ofSuccess: _ -> 'msg) - (ofError: _ -> 'msg) : Cmd<'msg> = + let inline either (task: 'a -> Async<_>) (arg: 'a) (ofSuccess: _ -> 'msg) (ofError: _ -> 'msg) : Cmd<'msg> = OfAsyncWith.either Async.Start task arg ofSuccess ofError /// Command that will evaluate an async block and map the success - let inline perform (task: 'a -> Async<_>) - (arg: 'a) - (ofSuccess: _ -> 'msg) : Cmd<'msg> = + let inline perform (task: 'a -> Async<_>) (arg: 'a) (ofSuccess: _ -> 'msg) : Cmd<'msg> = OfAsyncWith.perform Async.Start task arg ofSuccess /// Command that will evaluate an async block and map the error (of exception) - let inline attempt (task: 'a -> Async<_>) - (arg: 'a) - (ofError: _ -> 'msg) : Cmd<'msg> = + let inline attempt (task: 'a -> Async<_>) (arg: 'a) (ofError: _ -> 'msg) : Cmd<'msg> = OfAsyncWith.attempt Async.Start task arg ofError - + let inline msg (task: Async<'msg>) = OfAsyncWith.perform Async.Start (fun () -> task) () id - + let inline msgOption (task: Async<'msg option>) = OfAsyncWith.performOption Async.Start (fun () -> task) () id module OfAsyncImmediate = /// Command that will evaluate an async block and map the result /// into success or error (of exception) - let inline either (task: 'a -> Async<_>) - (arg: 'a) - (ofSuccess: _ -> 'msg) - (ofError: _ -> 'msg) : Cmd<'msg> = + let inline either (task: 'a -> Async<_>) (arg: 'a) (ofSuccess: _ -> 'msg) (ofError: _ -> 'msg) : Cmd<'msg> = OfAsyncWith.either Async.StartImmediate task arg ofSuccess ofError /// Command that will evaluate an async block and map the success - let inline perform (task: 'a -> Async<_>) - (arg: 'a) - (ofSuccess: _ -> 'msg) : Cmd<'msg> = + let inline perform (task: 'a -> Async<_>) (arg: 'a) (ofSuccess: _ -> 'msg) : Cmd<'msg> = OfAsyncWith.perform Async.StartImmediate task arg ofSuccess /// Command that will evaluate an async block and map the error (of exception) - let inline attempt (task: 'a -> Async<_>) - (arg: 'a) - (ofError: _ -> 'msg) : Cmd<'msg> = + let inline attempt (task: 'a -> Async<_>) (arg: 'a) (ofError: _ -> 'msg) : Cmd<'msg> = OfAsyncWith.attempt Async.StartImmediate task arg ofError module OfTask = /// Command to call a task and map the results - let inline either (task: 'a -> Task<_>) - (arg:'a) - (ofSuccess: _ -> 'msg) - (ofError: _ -> 'msg) : Cmd<'msg> = + let inline either (task: 'a -> Task<_>) (arg: 'a) (ofSuccess: _ -> 'msg) (ofError: _ -> 'msg) : Cmd<'msg> = OfAsync.either (task >> Async.AwaitTask) arg ofSuccess ofError /// Command to call a task and map the success - let inline perform (task: 'a -> Task<_>) - (arg:'a) - (ofSuccess: _ -> 'msg) : Cmd<'msg> = + let inline perform (task: 'a -> Task<_>) (arg: 'a) (ofSuccess: _ -> 'msg) : Cmd<'msg> = OfAsync.perform (task >> Async.AwaitTask) arg ofSuccess /// Command to call a task and map the error - let inline attempt (task: 'a -> #Task) - (arg:'a) - (ofError: _ -> 'msg) : Cmd<'msg> = + let inline attempt (task: 'a -> #Task) (arg: 'a) (ofError: _ -> 'msg) : Cmd<'msg> = OfAsync.attempt (task >> Async.AwaitTask) arg ofError - - let inline msg (task: Task<'msg>) = - OfAsync.msg (task |> Async.AwaitTask) - + + let inline msg (task: Task<'msg>) = OfAsync.msg(task |> Async.AwaitTask) + let inline msgOption (task: Task<'msg option>) = - OfAsync.msgOption (task |> Async.AwaitTask) + OfAsync.msgOption(task |> Async.AwaitTask) /// 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> = diff --git a/src/Fabulous/Component.fs b/src/Fabulous/Component.fs index 3e0e356a1..39a0a90b1 100644 --- a/src/Fabulous/Component.fs +++ b/src/Fabulous/Component.fs @@ -315,14 +315,14 @@ type Component(treeContext: ViewTreeContext, body: ComponentBody, context: Compo let viewNode = treeContext.GetViewNode _view Reconciler.update treeContext.CanReuseView (ValueSome prevRootWidget) currRootWidget viewNode - + member this.Dispose() = if _contextSubscription <> null then _contextSubscription.Dispose() - + if _context <> null then _context.Dispose() - + _body <- null _widget <- Unchecked.defaultof<_> _view <- null diff --git a/src/Fabulous/ComponentContext.fs b/src/Fabulous/ComponentContext.fs index 4600bb406..14c2fd995 100644 --- a/src/Fabulous/ComponentContext.fs +++ b/src/Fabulous/ComponentContext.fs @@ -67,17 +67,17 @@ type ComponentContext(initialSize: int) = member this.SetValue(key: int, value: 'T) = this.SetValueInternal(key, value) this.NeedsRender() - - member this.LinkDisposable(disposable: IDisposable) = - disposables.Add(disposable) - + + member this.LinkDisposable(disposable: IDisposable) = disposables.Add(disposable) + member this.Dispose() = for disposable in disposables do disposable.Dispose() + disposables.Clear() - + values <- Array.empty - + interface IDisposable with member this.Dispose() = this.Dispose() diff --git a/src/Fabulous/MvuComponent.fs b/src/Fabulous/MvuComponent.fs index 6add37c07..51a22d572 100644 --- a/src/Fabulous/MvuComponent.fs +++ b/src/Fabulous/MvuComponent.fs @@ -28,7 +28,9 @@ module MvuComponent = let ctx = new ComponentContext(1) - let runner = new Runner((fun () -> ctx.TryGetValue(0).Value), (fun v -> ctx.SetValue(0, v)), data.Program) + let runner = + new Runner((fun () -> ctx.TryGetValue(0).Value), (fun v -> ctx.SetValue(0, v)), data.Program) + ctx.LinkDisposable(runner) runner.Start(data.Arg) @@ -38,7 +40,7 @@ module MvuComponent = { treeContext with Dispatch = runner.Dispatch } - let comp = new Component(treeContext, data.Body, ctx) + let comp = new Component(treeContext, data.Body, ctx) let struct (node, view) = comp.CreateView(ValueSome widget) treeContext.SetComponent view comp @@ -56,7 +58,9 @@ module MvuComponent = let ctx = new ComponentContext(1) - let runner = new Runner((fun () -> ctx.TryGetValue(0).Value), (fun v -> ctx.SetValue(0, v)), data.Program) + let runner = + new Runner((fun () -> ctx.TryGetValue(0).Value), (fun v -> ctx.SetValue(0, v)), data.Program) + ctx.LinkDisposable(runner) runner.Start(data.Arg) diff --git a/src/Fabulous/Program.fs b/src/Fabulous/Program.fs index 7389f5e06..4b0f4ad78 100644 --- a/src/Fabulous/Program.fs +++ b/src/Fabulous/Program.fs @@ -73,12 +73,12 @@ module Program = /// Subscribe to external source of events, overrides existing subscription. /// Return the subscriptions that should be active based on the current model. /// Subscriptions will be started or stopped automatically to match. - let withSubscription (subscribe: 'model -> Sub<'msg>) (program: Program<'arg, 'model, 'msg>) = - { program with Subscribe = subscribe } - + let withSubscription (subscribe: 'model -> Sub<'msg>) (program: Program<'arg, 'model, 'msg>) = { program with Subscribe = subscribe } + /// Map existing subscription to external source of events. let mapSubscription map (program: Program<'arg, 'model, 'msg>) = - { program with Subscribe = map program.Subscribe } + { program with + Subscribe = map program.Subscribe } /// Configure how the output messages from Fabulous will be handled let withLogger (logger: Logger) (program: Program<'arg, 'model, 'msg>) = { program with Logger = logger } diff --git a/src/Fabulous/Runner.fs b/src/Fabulous/Runner.fs index 0e5a8bf3c..692907d48 100644 --- a/src/Fabulous/Runner.fs +++ b/src/Fabulous/Runner.fs @@ -11,26 +11,25 @@ type Runner<'arg, 'model, 'msg>(getState: unit -> 'model, setState: 'model -> un let mutable _activeSubs = Sub.Internal.empty let mutable _reentering = false let queue = ConcurrentQueue<'msg>() - + let onError (message, exn) = let ex = Exception(message, exn) + if not(program.ExceptionHandler ex) then raise ex - + let processMsgs dispatch msg = let mutable lastMsg = ValueSome msg - + while lastMsg.IsSome do let model = getState() let newModel, cmd = program.Update(lastMsg.Value, model) let subs = program.Subscribe(newModel) - + setState newModel - - _activeSubs <- - Sub.Internal.diff _activeSubs subs - |> Sub.Internal.Fx.change onError dispatch - + + _activeSubs <- Sub.Internal.diff _activeSubs subs |> Sub.Internal.Fx.change onError dispatch + Cmd.exec (fun ex -> onError("Error updating", ex)) dispatch cmd lastMsg <- @@ -48,37 +47,38 @@ type Runner<'arg, 'model, 'msg>(getState: unit -> 'model, setState: 'model -> un _reentering <- false with ex -> _reentering <- false + if not(program.ExceptionHandler ex) then reraise() let start arg = try _reentering <- true - + let model, cmd = program.Init(arg) setState model // Start the subscriptions let subs = program.Subscribe(model) - _activeSubs <- - Sub.Internal.diff _activeSubs subs - |> Sub.Internal.Fx.change onError dispatch + _activeSubs <- Sub.Internal.diff _activeSubs subs |> Sub.Internal.Fx.change onError dispatch // Execute the commands Cmd.exec (fun ex -> onError("Error initializing", ex)) dispatch cmd - + _reentering <- false with ex -> _reentering <- false + if not(program.ExceptionHandler(ex)) then reraise() - + let stop () = try _reentering <- true Sub.Internal.Fx.stop onError _activeSubs with ex -> _reentering <- false + if not(program.ExceptionHandler(ex)) then reraise() @@ -89,4 +89,4 @@ type Runner<'arg, 'model, 'msg>(getState: unit -> 'model, setState: 'model -> un member _.Dispatch(msg) = dispatch msg interface IDisposable with - member _.Dispose() = stop () \ No newline at end of file + member _.Dispose() = stop() diff --git a/src/Fabulous/Sub.fs b/src/Fabulous/Sub.fs index 147d38f02..04def9fe7 100644 --- a/src/Fabulous/Sub.fs +++ b/src/Fabulous/Sub.fs @@ -14,59 +14,53 @@ type Sub<'msg> = (SubId * Subscribe<'msg>) list module Sub = /// None - no subscriptions, also known as `[]` - let none : Sub<'msg> = - [] + let none: Sub<'msg> = [] /// Aggregate multiple subscriptions - let batch (subs: Sub<'msg> list) : Sub<'msg> = - List.concat subs + let batch (subs: Sub<'msg> list) : Sub<'msg> = List.concat subs /// When emitting the message, map to another type. /// To avoid ID conflicts with other components, scope SubIds with a prefix. let map (idPrefix: string) (f: 'a -> 'msg) (sub: Sub<'a>) : Sub<'msg> = - sub |> List.map (fun (subId, subscribe) -> - idPrefix :: subId, - fun dispatch -> subscribe (f >> dispatch)) + sub + |> List.map(fun (subId, subscribe) -> idPrefix :: subId, (fun dispatch -> subscribe(f >> dispatch))) module Internal = module SubId = - let toString (subId: SubId) = - String.Join("/", subId) + let toString (subId: SubId) = String.Join("/", subId) module Fx = let warnDupe onError subId = let ex = exn "Duplicate SubId" - onError ("Duplicate SubId: " + SubId.toString subId, ex) + onError("Duplicate SubId: " + SubId.toString subId, ex) let tryStop onError (subId, sub: IDisposable) = try sub.Dispose() with ex -> - onError ("Error stopping subscription: " + SubId.toString subId, ex) + onError("Error stopping subscription: " + SubId.toString subId, ex) let tryStart onError dispatch (subId, start) : (SubId * IDisposable) option = try - Some (subId, start dispatch) + Some(subId, start dispatch) with ex -> - onError ("Error starting subscription: " + SubId.toString subId, ex) + onError("Error starting subscription: " + SubId.toString subId, ex) None - let stop onError subs = - subs |> List.iter (tryStop onError) + let stop onError subs = subs |> List.iter(tryStop onError) let change onError dispatch (dupes, toStop, toKeep, toStart) = - dupes |> List.iter (warnDupe onError) - toStop |> List.iter (tryStop onError) - let started = toStart |> List.choose (tryStart onError dispatch) + dupes |> List.iter(warnDupe onError) + toStop |> List.iter(tryStop onError) + let started = toStart |> List.choose(tryStart onError dispatch) List.append toKeep started module NewSubs = - let (_dupes, _newKeys, _newSubs) as init = - List.empty, Set.empty, List.empty + let (_dupes, _newKeys, _newSubs) as init = List.empty, Set.empty, List.empty let update (subId, start) (dupes, newKeys, newSubs) = if Set.contains subId newKeys then @@ -74,17 +68,19 @@ module Sub = else dupes, Set.add subId newKeys, (subId, start) :: newSubs - let calculate subs = - List.foldBack update subs init + let calculate subs = List.foldBack update subs init let empty = List.empty let diff (activeSubs: (SubId * IDisposable) list) (sub: Sub<'msg>) = let keys = activeSubs |> List.map fst |> Set.ofList let dupes, newKeys, newSubs = NewSubs.calculate sub + if keys = newKeys then dupes, [], activeSubs, [] else - let toKeep, toStop = activeSubs |> List.partition (fun (k, _) -> Set.contains k newKeys) - let toStart = newSubs |> List.filter (fun (k, _) -> not (Set.contains k keys)) - dupes, toStop, toKeep, toStart \ No newline at end of file + let toKeep, toStop = + activeSubs |> List.partition(fun (k, _) -> Set.contains k newKeys) + + let toStart = newSubs |> List.filter(fun (k, _) -> not(Set.contains k keys)) + dupes, toStop, toKeep, toStart From 860e2eff90682b13e75cd091e95d11858a85abbb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Timoth=C3=A9=20Larivi=C3=A8re?= Date: Tue, 30 Jan 2024 18:04:34 +0100 Subject: [PATCH 3/5] Make ViewNode disposable --- src/Fabulous/Attributes.fs | 45 +++++++---------- src/Fabulous/Component.fs | 4 +- src/Fabulous/IViewNode.fs | 10 ++-- src/Fabulous/MvuComponent.fs | 4 +- src/Fabulous/Runner.fs | 1 + src/Fabulous/ViewNode.fs | 96 +++++++++++++++++++++++++----------- 6 files changed, 96 insertions(+), 64 deletions(-) diff --git a/src/Fabulous/Attributes.fs b/src/Fabulous/Attributes.fs index 5f377bffa..f7e84df03 100644 --- a/src/Fabulous/Attributes.fs +++ b/src/Fabulous/Attributes.fs @@ -217,7 +217,7 @@ module Attributes = // Trigger the unmounted event Dispatcher.dispatchEventForAllChildren itemNode widget Lifecycle.Unmounted - itemNode.Disconnect() + itemNode.Dispose() // Remove the child from the UI tree targetColl.RemoveAt(index) @@ -247,7 +247,7 @@ module Attributes = // Trigger the unmounted event for the old child Dispatcher.dispatchEventForAllChildren prevItemNode oldWidget Lifecycle.Unmounted - prevItemNode.Disconnect() + prevItemNode.Dispose() // Replace the existing child in the UI tree at the index with the new one targetColl[index] <- unbox view @@ -288,20 +288,16 @@ module Attributes = SimpleScalarAttributeDefinition.CreateAttributeData( ScalarAttributeComparers.noCompare, (fun _ (newValueOpt: MsgValue voption) node -> - let event = getEvent node.Target - match node.TryGetHandler(name) with | ValueNone -> () - | ValueSome handler -> event.RemoveHandler handler + | ValueSome handler -> handler.Dispose() match newValueOpt with - | ValueNone -> node.SetHandler(name, ValueNone) - + | ValueNone -> node.RemoveHandler(name) | ValueSome(MsgValue msg) -> - let handler = EventHandler(fun _ _ -> Dispatcher.dispatch node msg) - - event.AddHandler handler - node.SetHandler(name, ValueSome handler)) + let event = getEvent node.Target + let handler = event.Subscribe(fun _ -> Dispatcher.dispatch node msg) + node.SetHandler(name, handler)) ) |> AttributeDefinitionStore.registerScalar @@ -317,23 +313,21 @@ module Attributes = SimpleScalarAttributeDefinition.CreateAttributeData( ScalarAttributeComparers.noCompare, (fun _ (newValueOpt: ('args -> MsgValue) voption) (node: IViewNode) -> - let event = getEvent node.Target - match node.TryGetHandler(name) with | ValueNone -> () - | ValueSome handler -> event.RemoveHandler handler + | ValueSome handler -> handler.Dispose() match newValueOpt with - | ValueNone -> node.SetHandler(name, ValueNone) - + | ValueNone -> node.RemoveHandler(name) | ValueSome fn -> + let event = getEvent node.Target + let handler = - EventHandler<'args>(fun _ args -> + event.Subscribe(fun args -> let (MsgValue r) = fn args Dispatcher.dispatch node r) - node.SetHandler(name, ValueSome handler) - event.AddHandler handler) + node.SetHandler(name, handler)) ) |> AttributeDefinitionStore.registerScalar @@ -347,20 +341,15 @@ module Attributes = SimpleScalarAttributeDefinition.CreateAttributeData( ScalarAttributeComparers.noCompare, (fun _ (newValueOpt: (unit -> unit) voption) node -> - let event = getEvent(node.Target) - match node.TryGetHandler(name) with | ValueNone -> () - | ValueSome handler -> event.RemoveHandler handler + | ValueSome handler -> handler.Dispose() match newValueOpt with - | ValueNone -> node.SetHandler(name, ValueNone) - + | ValueNone -> node.RemoveHandler(name) | ValueSome(fn) -> - let handler = EventHandler(fun _ _ -> fn()) - - event.AddHandler handler - node.SetHandler(name, ValueSome handler)) + let event = getEvent node.Target + node.SetHandler(name, event.Subscribe(fun _ -> fn()))) ) |> AttributeDefinitionStore.registerScalar diff --git a/src/Fabulous/Component.fs b/src/Fabulous/Component.fs index 39a0a90b1..92950f523 100644 --- a/src/Fabulous/Component.fs +++ b/src/Fabulous/Component.fs @@ -357,7 +357,7 @@ module Component = let comp = new Component(treeContext, data.Body, ctx) let struct (node, view) = comp.CreateView(ValueSome widget) - treeContext.SetComponent view comp + treeContext.SetComponent comp view struct (node, view) AttachView = @@ -374,7 +374,7 @@ module Component = let comp = new Component(treeContext, data.Body, ctx) let node = comp.AttachView(widget, view) - treeContext.SetComponent view comp + treeContext.SetComponent comp view node } diff --git a/src/Fabulous/IViewNode.fs b/src/Fabulous/IViewNode.fs index cdd9884dc..11ba8432d 100644 --- a/src/Fabulous/IViewNode.fs +++ b/src/Fabulous/IViewNode.fs @@ -1,5 +1,6 @@ namespace Fabulous +open System open Fabulous type ViewRef(onAttached, onDetached) = @@ -40,6 +41,8 @@ type ViewTreeContext = SetComponent: obj -> obj -> unit } and IViewNode = + inherit IDisposable + /// The view that is being rendered abstract member Target: obj @@ -62,13 +65,12 @@ and IViewNode = abstract member MapMsg: (obj -> obj) option with get, set /// Return the event handler for a given attribute key if set - abstract member TryGetHandler<'T> : string -> 'T voption + abstract member TryGetHandler: string -> IDisposable voption /// Set the event handler for a given attribute name - abstract member SetHandler<'T> : string * 'T voption -> unit + abstract member SetHandler: string * IDisposable -> unit - /// Disconnect the node from the tree - abstract member Disconnect: unit -> unit + abstract member RemoveHandler: string -> unit /// Apply the diffing result to this node abstract member ApplyDiff: WidgetDiff inref -> unit diff --git a/src/Fabulous/MvuComponent.fs b/src/Fabulous/MvuComponent.fs index 51a22d572..379e89e5f 100644 --- a/src/Fabulous/MvuComponent.fs +++ b/src/Fabulous/MvuComponent.fs @@ -43,7 +43,7 @@ module MvuComponent = let comp = new Component(treeContext, data.Body, ctx) let struct (node, view) = comp.CreateView(ValueSome widget) - treeContext.SetComponent view comp + treeContext.SetComponent comp view struct (node, view) AttachView = @@ -73,7 +73,7 @@ module MvuComponent = let comp = new Component(treeContext, data.Body, ctx) let node = comp.AttachView(widget, view) - treeContext.SetComponent view comp + treeContext.SetComponent comp view node } diff --git a/src/Fabulous/Runner.fs b/src/Fabulous/Runner.fs index 692907d48..910f230a8 100644 --- a/src/Fabulous/Runner.fs +++ b/src/Fabulous/Runner.fs @@ -76,6 +76,7 @@ type Runner<'arg, 'model, 'msg>(getState: unit -> 'model, setState: 'model -> un try _reentering <- true Sub.Internal.Fx.stop onError _activeSubs + _activeSubs <- Sub.Internal.empty with ex -> _reentering <- false diff --git a/src/Fabulous/ViewNode.fs b/src/Fabulous/ViewNode.fs index 2cca381ca..4efed81de 100644 --- a/src/Fabulous/ViewNode.fs +++ b/src/Fabulous/ViewNode.fs @@ -1,18 +1,32 @@ namespace Fabulous +open System open System.Collections.Generic open Fabulous /// Define the logic to apply diffs and store event handlers of its target control [] -type ViewNode(parent: IViewNode option, treeContext: ViewTreeContext, targetRef: System.WeakReference) = - - let mutable _isDisconnected = false +type ViewNode = + val mutable parent: IViewNode option + val mutable treeContext: ViewTreeContext + val mutable targetRef: WeakReference + val mutable isDisposed: bool + val mutable memoizedWidget: Widget option + val mutable mapMsg: (obj -> obj) option // TODO consider combine handlers mapMsg and property bag // also we can probably use just Dictionary instead of Map because // ViewNode is supposed to be mutable, stateful and persistent object - let _handlers = Dictionary() + val handlers: Dictionary + + new(parent: IViewNode option, treeContext: ViewTreeContext, target: WeakReference) = + { parent = parent + treeContext = treeContext + targetRef = target + handlers = Dictionary() + isDisposed = false + memoizedWidget = None + mapMsg = None } member inline private this.ApplyScalarDiffs(diffs: ScalarChanges inref) : unit = let node = this :> IViewNode @@ -48,8 +62,6 @@ type ViewNode(parent: IViewNode option, treeContext: ViewTreeContext, targetRef: scalar.UpdateNode (ValueSome removed.Value) ValueNone node - - | ScalarChange.Updated(oldAttr, newAttr) -> let key = oldAttr.Key @@ -91,42 +103,70 @@ type ViewNode(parent: IViewNode option, treeContext: ViewTreeContext, targetRef: definition.UpdateNode ValueNone (ValueSome added.Value) (this :> IViewNode) - | WidgetCollectionChange.Removed removed -> let definition = (AttributeDefinitionStore.getWidgetCollection removed.Key) definition.UpdateNode (ValueSome removed.Value) ValueNone (this :> IViewNode) - | WidgetCollectionChange.Updated struct (oldAttr, newAttr, diffs) -> let definition = (AttributeDefinitionStore.getWidgetCollection newAttr.Key) definition.ApplyDiff oldAttr.Value diffs (this :> IViewNode) interface IViewNode with - member _.Target = targetRef.Target - member _.TreeContext = treeContext - member val MemoizedWidget: Widget option = None with get, set - member _.Parent = parent - member val MapMsg: (obj -> obj) option = None with get, set - member _.IsDisconnected = _isDisconnected - - member _.TryGetHandler<'T>(key: string) = - match _handlers.TryGetValue(key) with + member this.Target = this.targetRef.Target + member this.TreeContext = this.treeContext + + member this.MemoizedWidget + with get () = this.memoizedWidget + and set value = this.memoizedWidget <- value + + member this.Parent = this.parent + + member this.MapMsg + with get () = this.mapMsg + and set value = this.mapMsg <- value + + member this.IsDisconnected = this.isDisposed + + member this.TryGetHandler(key: string) = + match this.handlers.TryGetValue(key) with | false, _ -> ValueNone - | true, v -> ValueSome(unbox<'T> v) + | true, handler -> ValueSome(handler) + + member this.SetHandler(key: string, handler: IDisposable) = this.handlers[key] <- handler + + member this.RemoveHandler(key: string) = + if this.handlers.ContainsKey(key) then + let handler = this.handlers[key] + this.handlers.Remove(key) |> ignore + handler.Dispose() + + member this.Dispose() = + this.isDisposed <- true + + // Dispose all the event handlers of this node + for kvp in this.handlers do + kvp.Value.Dispose() + + this.handlers.Clear() + + // Dispose the attached Component if any + if this.targetRef.IsAlive then + let comp = this.treeContext.GetComponent(this.targetRef.Target) :?> IDisposable - member _.SetHandler<'T>(key: string, handlerOpt: 'T voption) = - match handlerOpt with - | ValueNone -> _handlers.Remove(key) |> ignore - | ValueSome v -> _handlers[key] <- box v + if comp <> null then + comp.Dispose() + this.treeContext.SetComponent null this.targetRef.Target - member _.Disconnect() = _isDisconnected <- true + this.parent <- None + this.treeContext <- Unchecked.defaultof<_> + this.targetRef <- null - member x.ApplyDiff(diff) = - if not targetRef.IsAlive then + member this.ApplyDiff(diff) = + if not this.targetRef.IsAlive then () else - x.ApplyWidgetDiffs(&diff.WidgetChanges) - x.ApplyWidgetCollectionDiffs(&diff.WidgetCollectionChanges) - x.ApplyScalarDiffs(&diff.ScalarChanges) + this.ApplyWidgetDiffs(&diff.WidgetChanges) + this.ApplyWidgetCollectionDiffs(&diff.WidgetCollectionChanges) + this.ApplyScalarDiffs(&diff.ScalarChanges) From 293178499be0d44d904e1de11221a669579e9f00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Timoth=C3=A9=20Larivi=C3=A8re?= Date: Tue, 30 Jan 2024 18:28:47 +0100 Subject: [PATCH 4/5] Fix unit tests --- .../APISketchTests/TestUI.Attributes.fs | 56 ++++++++++++------- .../APISketchTests/TestUI.Component.fs | 7 ++- .../APISketchTests/TestUI.Widgets.fs | 3 +- 3 files changed, 44 insertions(+), 22 deletions(-) diff --git a/src/Fabulous.Tests/APISketchTests/TestUI.Attributes.fs b/src/Fabulous.Tests/APISketchTests/TestUI.Attributes.fs index 9effb6f2a..e37175654 100644 --- a/src/Fabulous.Tests/APISketchTests/TestUI.Attributes.fs +++ b/src/Fabulous.Tests/APISketchTests/TestUI.Attributes.fs @@ -18,18 +18,22 @@ module TestUI_Attributes = let btn = node.Target :?> IButton - match node.TryGetHandler(name) with + match node.TryGetHandler(name) with | ValueNone -> () - | ValueSome handlerId -> btn.RemovePressListener handlerId + | ValueSome handler -> handler.Dispose() match newValueOpt with - | ValueNone -> node.SetHandler(name, ValueNone) + | ValueNone -> node.RemoveHandler(name) | ValueSome msg -> let handler () = Dispatcher.dispatch node msg - let handlerId = btn.AddPressListener handler - node.SetHandler(name, ValueSome handlerId)) + + let disposable = + { new IDisposable with + member _.Dispose() = btn.RemovePressListener handlerId } + + node.SetHandler(name, disposable)) ) |> AttributeDefinitionStore.registerScalar @@ -44,18 +48,22 @@ module TestUI_Attributes = let btn = node.Target :?> IButton - match node.TryGetHandler(name) with + match node.TryGetHandler(name) with | ValueNone -> () - | ValueSome handlerId -> btn.RemoveTapListener handlerId + | ValueSome handler -> handler.Dispose() match newValueOpt with - | ValueNone -> node.SetHandler(name, ValueNone) + | ValueNone -> node.RemoveHandler(name) | ValueSome msg -> let handler () = Dispatcher.dispatch node msg - let handlerId = btn.AddTapListener handler - node.SetHandler(name, ValueSome handlerId)) + + let disposable = + { new IDisposable with + member _.Dispose() = btn.RemoveTapListener handlerId } + + node.SetHandler(name, disposable)) ) |> AttributeDefinitionStore.registerScalar @@ -70,18 +78,22 @@ module TestUI_Attributes = let btn = node.Target :?> IButton - match node.TryGetHandler(name) with + match node.TryGetHandler(name) with | ValueNone -> () - | ValueSome handlerId -> btn.RemoveTap2Listener handlerId + | ValueSome handler -> handler.Dispose() match newValueOpt with - | ValueNone -> node.SetHandler(name, ValueNone) + | ValueNone -> node.RemoveHandler(name) | ValueSome msg -> let handler () = Dispatcher.dispatch node msg - let handlerId = btn.AddTap2Listener handler - node.SetHandler(name, ValueSome handlerId)) + + let disposable = + { new IDisposable with + member _.Dispose() = btn.RemoveTap2Listener handlerId } + + node.SetHandler(name, disposable)) ) |> AttributeDefinitionStore.registerScalar @@ -96,18 +108,22 @@ module TestUI_Attributes = let btn = node.Target :?> IContainer - match node.TryGetHandler(name) with + match node.TryGetHandler(name) with | ValueNone -> () - | ValueSome handlerId -> btn.RemoveTapListener handlerId + | ValueSome handler -> handler.Dispose() match newValueOpt with - | ValueNone -> node.SetHandler(name, ValueNone) + | ValueNone -> node.RemoveHandler(name) | ValueSome msg -> let handler () = Dispatcher.dispatch node msg - let handlerId = btn.AddTapListener handler - node.SetHandler(name, ValueSome handlerId)) + + let disposable = + { new IDisposable with + member _.Dispose() = btn.RemoveTapListener handlerId } + + node.SetHandler(name, disposable)) ) |> AttributeDefinitionStore.registerScalar diff --git a/src/Fabulous.Tests/APISketchTests/TestUI.Component.fs b/src/Fabulous.Tests/APISketchTests/TestUI.Component.fs index 88787b7c1..04758f2f0 100644 --- a/src/Fabulous.Tests/APISketchTests/TestUI.Component.fs +++ b/src/Fabulous.Tests/APISketchTests/TestUI.Component.fs @@ -9,4 +9,9 @@ module TestUI_Component = let ComponentProperty = "ComponentProperty" let getComponent (target: obj) = - (target :?> TestViewElement).PropertyBag.Item ComponentProperty + match (target :?> TestViewElement).PropertyBag.TryGetValue(ComponentProperty) with + | true, comp -> comp + | _ -> null + + let setComponent (comp: obj) (target: obj) = + (target :?> TestViewElement).PropertyBag.Add(ComponentProperty, comp) diff --git a/src/Fabulous.Tests/APISketchTests/TestUI.Widgets.fs b/src/Fabulous.Tests/APISketchTests/TestUI.Widgets.fs index 476b3ccf6..71543f877 100644 --- a/src/Fabulous.Tests/APISketchTests/TestUI.Widgets.fs +++ b/src/Fabulous.Tests/APISketchTests/TestUI.Widgets.fs @@ -41,7 +41,7 @@ module TestUI_Widgets = | ValueNone -> None | ValueSome parent -> Some parent - let viewNode = ViewNode(parentNode, context, weakReference) + let viewNode = new ViewNode(parentNode, context, weakReference) view.PropertyBag.Add(ViewNode.ViewNodeProperty, viewNode) @@ -214,6 +214,7 @@ module TestUI_Widgets = MinLogLevel = LogLevel.Fatal } Dispatch = fun msg -> unbox<'msg> msg |> x.ProcessMessage GetComponent = Component.getComponent + SetComponent = Component.setComponent SyncAction = fun fn -> fn() } member x.ProcessMessage(msg: 'msg) = From 4a93b2f9b459bd8dd769bfcb409162ba5f8b16f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Timoth=C3=A9=20Larivi=C3=A8re?= Date: Tue, 30 Jan 2024 18:33:18 +0100 Subject: [PATCH 5/5] Update changelog --- CHANGELOG.md | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d83bf7332..2333354fc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 _No unreleased changes_ +## [2.5.0-pre8] - 2024-01-30 + +### Changed +- Dispose properly ViewNode and Component when Widget is removed from tree by @TimLariviere (https://github.com/fabulous-dev/Fabulous/pull/1066) + ## [2.5.0-pre7] - 2024-01-30 ### Added @@ -90,7 +95,8 @@ _No unreleased changes_ ### Changed - Fabulous.XamarinForms & Fabulous.MauiControls have been moved been out of the Fabulous repository. Find them in their own repositories: [https://github.com/fabulous-dev/Fabulous.XamarinForms](https://github.com/fabulous-dev/Fabulous.XamarinForms) / [https://github.com/fabulous-dev/Fabulous.MauiControls](https://github.com/fabulous-dev/Fabulous.MauiControls) -[unreleased]: https://github.com/fabulous-dev/Fabulous/compare/2.5.0-pre7...HEAD +[unreleased]: https://github.com/fabulous-dev/Fabulous/compare/2.5.0-pre8...HEAD +[2.5.0-pre8]: https://github.com/fabulous-dev/Fabulous/releases/tag/2.5.0-pre8 [2.5.0-pre7]: https://github.com/fabulous-dev/Fabulous/releases/tag/2.5.0-pre7 [2.5.0-pre6]: https://github.com/fabulous-dev/Fabulous/releases/tag/2.5.0-pre6 [2.5.0-pre5]: https://github.com/fabulous-dev/Fabulous/releases/tag/2.5.0-pre5