Skip to content

Commit

Permalink
Create an immutable helper to offload bindings management
Browse files Browse the repository at this point in the history
  • Loading branch information
@marner2
marner2 committed Oct 19, 2022
1 parent 56d5416 commit e20870b
Showing 1 changed file with 102 additions and 62 deletions.
164 changes: 102 additions & 62 deletions src/Elmish.WPF/DynamicViewModel.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,6 +26,75 @@ module internal Helpers =
member this.CompareBindings() : Binding<'model, 'msg> -> Binding<'model, 'msg> -> int =
fun a b -> this.Recursive(a.Data) - this.Recursive(b.Data)

type internal ViewModelHelper<'model, 'msg> =
{ GetSender: unit -> obj
LoggingArgs: LoggingViewModelArgs
Model: 'model
Bindings: IReadOnlyDictionary<string, VmBinding<'model, 'msg, obj>>
ValidationErrors: IReadOnlyDictionary<string, string list ref>
PropertyChanged: Event<PropertyChangedEventHandler, PropertyChangedEventArgs>
ErrorsChanged: DelegateEvent<EventHandler<DataErrorsChangedEventArgs>> }

interface INotifyPropertyChanged with
[<CLIEvent>]
member x.PropertyChanged = x.PropertyChanged.Publish

interface INotifyDataErrorInfo with
[<CLIEvent>]
member x.ErrorsChanged = x.ErrorsChanged.Publish
member x.HasErrors =
// WPF calls this too often, so don't log https://github.com/elmish/Elmish.WPF/issues/354
x.ValidationErrors
|> Seq.map (fun (Kvp(_, errors)) -> errors.Value)
|> Seq.filter (not << List.isEmpty)
|> (not << Seq.isEmpty)
member x.GetErrors name =
let name = name |> Option.ofObj |> Option.defaultValue "<null>" // entity-level errors are being requested when given null or "" https://docs.microsoft.com/en-us/dotnet/api/system.componentmodel.inotifydataerrorinfo.geterrors#:~:text=null%20or%20Empty%2C%20to%20retrieve%20entity-level%20errors
x.LoggingArgs.log.LogTrace("[{BindingNameChain}] GetErrors {BindingName}", x.LoggingArgs.nameChain, name)
x.ValidationErrors
|> IReadOnlyDictionary.tryFind name
|> Option.map (fun errors -> errors.Value)
|> Option.defaultValue []
|> (fun x -> upcast x)

module internal ViewModelHelper =

let create getSender args bindings validationErrors ={
GetSender = getSender
LoggingArgs = args.loggingArgs
Model = args.initialModel
ValidationErrors = validationErrors
Bindings = bindings
PropertyChanged = Event<PropertyChangedEventHandler, PropertyChangedEventArgs>()
ErrorsChanged = DelegateEvent<EventHandler<DataErrorsChangedEventArgs>>()
}

let updateModel newModel helper =
let {
log = log
nameChain = nameChain } = helper.LoggingArgs

let raisePropertyChanged name =
log.LogTrace("[{BindingNameChain}] PropertyChanged {BindingName}", nameChain, name)
helper.PropertyChanged.Trigger(helper.GetSender (), PropertyChangedEventArgs name)
let raiseCanExecuteChanged (cmd: Command) =
cmd.RaiseCanExecuteChanged ()
let raiseErrorsChanged name =
log.LogTrace("[{BindingNameChain}] ErrorsChanged {BindingName}", nameChain, name)
helper.ErrorsChanged.Trigger([| helper.GetSender (); box <| DataErrorsChangedEventArgs name |])

let eventsToRaise =
helper.Bindings
|> Seq.collect (fun (Kvp (name, binding)) -> Update(helper.LoggingArgs, name).Recursive(helper.Model, newModel, binding))
|> Seq.toList
eventsToRaise
|> List.iter (function
| ErrorsChanged name -> raiseErrorsChanged name
| PropertyChanged name -> raisePropertyChanged name
| CanExecuteChanged cmd -> cmd |> raiseCanExecuteChanged)

{ helper with Model = newModel }

type [<AllowNullLiteral>] internal DynamicViewModel<'model, 'msg>
( args: ViewModelArgs<'model, 'msg>,
bindings: Binding<'model, 'msg> list)
Expand All @@ -41,40 +110,28 @@ type [<AllowNullLiteral>] internal DynamicViewModel<'model, 'msg>
nameChain = nameChain
} = loggingArgs

let mutable currentModel = initialModel

let propertyChanged = Event<PropertyChangedEventHandler, PropertyChangedEventArgs>()
let errorsChanged = DelegateEvent<EventHandler<DataErrorsChangedEventArgs>>()

let raisePropertyChanged name =
log.LogTrace("[{BindingNameChain}] PropertyChanged {BindingName}", nameChain, name)
propertyChanged.Trigger(this, PropertyChangedEventArgs name)
let raiseCanExecuteChanged (cmd: Command) =
cmd.RaiseCanExecuteChanged ()
let raiseErrorsChanged name =
log.LogTrace("[{BindingNameChain}] ErrorsChanged {BindingName}", nameChain, name)
errorsChanged.Trigger([| box this; box <| DataErrorsChangedEventArgs name |])

let getFunctionsForSubModelSelectedItem initializedBindings (name: string) =
initializedBindings
|> IReadOnlyDictionary.tryFind name
|> function
| Some b ->
match FuncsFromSubModelSeqKeyed().Recursive(b) with
| Some x -> Some x
| None -> log.LogError("SubModelSelectedItem binding referenced binding {SubModelSeqBindingName} but it is not a SubModelSeq binding", name)
let (bindings, validationErrors) =
let getFunctionsForSubModelSelectedItem initializedBindings (name: string) =
initializedBindings
|> IReadOnlyDictionary.tryFind name
|> function
| Some b ->
match FuncsFromSubModelSeqKeyed().Recursive(b) with
| Some x -> Some x
| None -> log.LogError("SubModelSelectedItem binding referenced binding {SubModelSeqBindingName} but it is not a SubModelSeq binding", name)
None
| None -> log.LogError("SubModelSelectedItem binding referenced binding {SubModelSeqBindingName} but no binding was found with that name", name)
None
| None -> log.LogError("SubModelSelectedItem binding referenced binding {SubModelSeqBindingName} but no binding was found with that name", name)
None

let initializeBinding initializedBindings binding =
Initialize(loggingArgs, binding.Name, getFunctionsForSubModelSelectedItem initializedBindings)
.Recursive(initialModel, dispatch, (fun () -> currentModel), binding.Data)
let initializeBinding initializedBindings binding =
Initialize(loggingArgs, binding.Name, getFunctionsForSubModelSelectedItem initializedBindings)
.Recursive(initialModel, dispatch, (fun () -> this.CurrentModel), binding.Data)

let (bindings, validationErrors) =
log.LogTrace("[{BindingNameChain}] Initializing bindings", nameChain)

let bindingDict = Dictionary<string, VmBinding<'model, 'msg, obj>>(bindings.Length)
let validationDict = Dictionary<string, string list ref>()

let sortedBindings =
bindings
|> List.sortWith (SubModelSelectedItemLast().CompareBindings())
Expand All @@ -92,30 +149,22 @@ type [<AllowNullLiteral>] internal DynamicViewModel<'model, 'msg>
(bindingDict :> IReadOnlyDictionary<_,_>,
validationDict :> IReadOnlyDictionary<_,_>)


member internal _.CurrentModel : 'model = currentModel

member internal _.UpdateModel (newModel: 'model) : unit =
let eventsToRaise =
let mutable helper =
ViewModelHelper.create
(fun () -> this)
args
bindings
|> Seq.collect (fun (Kvp (name, binding)) -> Update(loggingArgs, name).Recursive(currentModel, newModel, binding))
|> Seq.toList
currentModel <- newModel
eventsToRaise
|> List.iter (function
| ErrorsChanged name -> raiseErrorsChanged name
| PropertyChanged name -> raisePropertyChanged name
| CanExecuteChanged cmd -> cmd |> raiseCanExecuteChanged)
validationErrors

override _.TryGetMember (binder, result) =
log.LogTrace("[{BindingNameChain}] TryGetMember {BindingName}", nameChain, binder.Name)
match bindings.TryGetValue binder.Name with
match helper.Bindings.TryGetValue binder.Name with
| false, _ ->
log.LogError("[{BindingNameChain}] TryGetMember FAILED: Property {BindingName} doesn't exist", nameChain, binder.Name)
false
| true, binding ->
try
match Get(nameChain).Recursive(currentModel, binding) with
match Get(nameChain).Recursive(helper.Model, binding) with
| Ok v ->
result <- v
true
Expand All @@ -131,13 +180,13 @@ type [<AllowNullLiteral>] internal DynamicViewModel<'model, 'msg>

override _.TrySetMember (binder, value) =
log.LogTrace("[{BindingNameChain}] TrySetMember {BindingName}", nameChain, binder.Name)
match bindings.TryGetValue binder.Name with
match helper.Bindings.TryGetValue binder.Name with
| false, _ ->
log.LogError("[{BindingNameChain}] TrySetMember FAILED: Property {BindingName} doesn't exist", nameChain, binder.Name)
false
| true, binding ->
try
let success = Set(value).Recursive(currentModel, binding)
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)
success
Expand All @@ -147,27 +196,18 @@ type [<AllowNullLiteral>] internal DynamicViewModel<'model, 'msg>

override _.GetDynamicMemberNames () =
log.LogTrace("[{BindingNameChain}] GetDynamicMemberNames", nameChain)
bindings.Keys
helper.Bindings.Keys

member _.UpdateModel(newModel: 'model) = helper <- ViewModelHelper.updateModel newModel helper

member _.CurrentModel = helper.Model

interface INotifyPropertyChanged with
[<CLIEvent>]
member _.PropertyChanged = propertyChanged.Publish
member _.PropertyChanged = (helper :> INotifyPropertyChanged).PropertyChanged

interface INotifyDataErrorInfo with
[<CLIEvent>]
member _.ErrorsChanged = errorsChanged.Publish
member _.HasErrors =
// WPF calls this too often, so don't log https://github.com/elmish/Elmish.WPF/issues/354
validationErrors
|> Seq.map (fun (Kvp(_, errors)) -> errors.Value)
|> Seq.filter (not << List.isEmpty)
|> (not << Seq.isEmpty)
member _.GetErrors name =
let name = name |> Option.ofObj |> Option.defaultValue "<null>" // entity-level errors are being requested when given null or "" https://docs.microsoft.com/en-us/dotnet/api/system.componentmodel.inotifydataerrorinfo.geterrors#:~:text=null%20or%20Empty%2C%20to%20retrieve%20entity-level%20errors
log.LogTrace("[{BindingNameChain}] GetErrors {BindingName}", nameChain, name)
validationErrors
|> IReadOnlyDictionary.tryFind name
|> Option.map (fun errors -> errors.Value)
|> Option.defaultValue []
|> (fun x -> upcast x)
member _.ErrorsChanged = (helper :> INotifyDataErrorInfo).ErrorsChanged
member _.HasErrors = (helper :> INotifyDataErrorInfo).HasErrors
member _.GetErrors name = (helper :> INotifyDataErrorInfo).GetErrors name

0 comments on commit e20870b

Please sign in to comment.