From 2af2c23f99533533f1faa75b35b5d9b26cc995b4 Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Sat, 6 Aug 2022 15:19:20 -0500 Subject: [PATCH 1/5] Remove minor type boxing on T and box at createBinding --- src/Elmish.WPF/BindingData.fs | 117 ++++++++++++++++++++++++----- src/Elmish.WPF/DynamicViewModel.fs | 2 +- src/Elmish.WPF/Merge.fs | 8 +- 3 files changed, 101 insertions(+), 26 deletions(-) diff --git a/src/Elmish.WPF/BindingData.fs b/src/Elmish.WPF/BindingData.fs index 4f99f363..1358f9bc 100644 --- a/src/Elmish.WPF/BindingData.fs +++ b/src/Elmish.WPF/BindingData.fs @@ -159,6 +159,92 @@ and BindingData<'model, 'msg, 't> = module BindingData = + module private MapT = + + let baseCase (fOut: 't0 -> 't1) (fIn: 't1 -> 't0) = + function + | OneWayData d -> OneWayData { + Get = d.Get >> fOut + } + | OneWayToSourceData d -> OneWayToSourceData { + Set = fIn >> d.Set + } + | OneWaySeqData d -> OneWaySeqData { + Get = d.Get + CreateCollection = d.CreateCollection >> CollectionTarget.mapCollection fOut + GetId = d.GetId + ItemEquals = d.ItemEquals + } + | TwoWayData d -> TwoWayData { + Get = d.Get >> fOut + Set = fIn >> d.Set + } + | CmdData d -> CmdData { + Exec = d.Exec + CanExec = d.CanExec + AutoRequery = d.AutoRequery + } + | SubModelData d -> SubModelData { + GetModel = d.GetModel + CreateViewModel = d.CreateViewModel >> fOut + UpdateViewModel = (fun (vm,m) -> d.UpdateViewModel (fIn vm, m)) + ToMsg = d.ToMsg + } + | SubModelWinData d -> SubModelWinData { + GetState = d.GetState + CreateViewModel = d.CreateViewModel >> fOut + UpdateViewModel = (fun (vm,m) -> d.UpdateViewModel (fIn vm, m)) + ToMsg = d.ToMsg + GetWindow = d.GetWindow + IsModal = d.IsModal + OnCloseRequested = d.OnCloseRequested + } + | SubModelSeqUnkeyedData d -> SubModelSeqUnkeyedData { + GetModels = d.GetModels + CreateViewModel = d.CreateViewModel + CreateCollection = d.CreateCollection >> CollectionTarget.mapCollection fOut + UpdateViewModel = d.UpdateViewModel + ToMsg = d.ToMsg + } + | SubModelSeqKeyedData d -> SubModelSeqKeyedData { + GetSubModels = d.GetSubModels + CreateViewModel = d.CreateViewModel + CreateCollection = d.CreateCollection >> CollectionTarget.mapCollection fOut + UpdateViewModel = d.UpdateViewModel + ToMsg = d.ToMsg + VmToId = d.VmToId + BmToId = d.BmToId + } + | SubModelSelectedItemData d -> SubModelSelectedItemData { + Get = d.Get + Set = d.Set + SubModelSeqBindingName = d.SubModelSeqBindingName + } + + let rec recursiveCase<'model, 'msg, 't0, 't1> (fOut: 't0 -> 't1) (fIn: 't1 -> 't0) + : BindingData<'model, 'msg, 't0> -> BindingData<'model, 'msg, 't1> = + function + | BaseBindingData d -> d |> baseCase fOut fIn |> BaseBindingData + | CachingData d -> d |> recursiveCase<'model, 'msg, 't0, 't1> fOut fIn |> CachingData + | ValidationData d -> ValidationData { + BindingData = recursiveCase<'model, 'msg, 't0, 't1> fOut fIn d.BindingData + Validate = d.Validate + } + | LazyData d -> LazyData { + Get = d.Get + Set = d.Set + BindingData = recursiveCase fOut fIn d.BindingData + Equals = d.Equals + } + | AlterMsgStreamData d -> AlterMsgStreamData { + BindingData = recursiveCase fOut fIn d.BindingData + AlterMsgStream = d.AlterMsgStream + Get = d.Get + Set = d.Set + } + + let boxT b = MapT.recursiveCase box unbox b + let mapModel f = let binaryHelper binary x m = binary x (f m) let baseCase = function @@ -403,16 +489,15 @@ module BindingData = let mapMinorTypes (outMapA: 'a -> 'a0) (outMapId: 'id -> 'id0) - (outMapACollection: 'aCollection -> 'aCollection0) (inMapA: 'a0 -> 'a) (d: OneWaySeqData<'model, 'a, 'aCollection, 'id>) = { Get = d.Get >> Seq.map outMapA - CreateCollection = Seq.map inMapA >> d.CreateCollection >> CollectionTarget.map outMapA outMapACollection inMapA + CreateCollection = Seq.map inMapA >> d.CreateCollection >> CollectionTarget.mapA outMapA inMapA GetId = inMapA >> d.GetId >> outMapId ItemEquals = fun a1 a2 -> d.ItemEquals (inMapA a1) (inMapA a2) } - let boxMinorTypes d = d |> mapMinorTypes box box box unbox + let boxMinorTypes d = d |> mapMinorTypes box box unbox let create itemEquals getId = { Get = (fun x -> upcast x) @@ -530,18 +615,16 @@ module BindingData = let mapMinorTypes (outMapBindingModel: 'bindingModel -> 'bindingModel0) (outMapBindingMsg: 'bindingMsg -> 'bindingMsg0) - (outMapBindingViewModel: 'vm -> 'vm0) (inMapBindingModel: 'bindingModel0 -> 'bindingModel) (inMapBindingMsg: 'bindingMsg0 -> 'bindingMsg) - (inMapBindingViewModel: 'vm0 -> 'vm) (d: SubModelData<'model, 'msg, 'bindingModel, 'bindingMsg, 'vm>) = { GetModel = d.GetModel >> ValueOption.map outMapBindingModel - CreateViewModel = fun args -> d.CreateViewModel(args |> ViewModelArgs.map inMapBindingModel outMapBindingMsg) |> outMapBindingViewModel - UpdateViewModel = fun (vm, m) -> (inMapBindingViewModel vm, inMapBindingModel m) |> d.UpdateViewModel + CreateViewModel = fun args -> d.CreateViewModel(args |> ViewModelArgs.map inMapBindingModel outMapBindingMsg) + UpdateViewModel = fun (vm, m) -> (vm, inMapBindingModel m) |> d.UpdateViewModel ToMsg = fun m bMsg -> d.ToMsg m (inMapBindingMsg bMsg) } - let boxMinorTypes d = d |> mapMinorTypes box box box unbox unbox unbox + let boxMinorTypes d = d |> mapMinorTypes box box unbox unbox let create createViewModel updateViewModel = { GetModel = id @@ -577,21 +660,19 @@ module BindingData = let mapMinorTypes (outMapBindingModel: 'bindingModel -> 'bindingModel0) (outMapBindingMsg: 'bindingMsg -> 'bindingMsg0) - (outMapBindingViewModel: 'vm -> 'vm0) (inMapBindingModel: 'bindingModel0 -> 'bindingModel) (inMapBindingMsg: 'bindingMsg0 -> 'bindingMsg) - (inMapBindingViewModel: 'vm0 -> 'vm) (d: SubModelWinData<'model, 'msg, 'bindingModel, 'bindingMsg, 'vm>) = { GetState = d.GetState >> WindowState.map outMapBindingModel - CreateViewModel = fun args -> d.CreateViewModel(args |> ViewModelArgs.map inMapBindingModel outMapBindingMsg) |> outMapBindingViewModel - UpdateViewModel = fun (vm, m) -> d.UpdateViewModel (inMapBindingViewModel vm, inMapBindingModel m) + CreateViewModel = fun args -> d.CreateViewModel(args |> ViewModelArgs.map inMapBindingModel outMapBindingMsg) + UpdateViewModel = fun (vm, m) -> d.UpdateViewModel (vm, inMapBindingModel m) ToMsg = fun m bMsg -> d.ToMsg m (inMapBindingMsg bMsg) GetWindow = d.GetWindow IsModal = d.IsModal OnCloseRequested = d.OnCloseRequested } - let boxMinorTypes d = d |> mapMinorTypes box box box unbox unbox unbox + let boxMinorTypes d = d |> mapMinorTypes box box unbox unbox let create getState createViewModel updateViewModel toMsg getWindow isModal onCloseRequested = { GetState = getState @@ -636,19 +717,18 @@ module BindingData = (outMapBindingModel: 'bindingModel -> 'bindingModel0) (outMapBindingMsg: 'bindingMsg -> 'bindingMsg0) (outMapBindingViewModel: 'vm -> 'vm0) - (outMapBindingVmCollection: 'vmCollection -> 'vmCollection0) (inMapBindingModel: 'bindingModel0 -> 'bindingModel) (inMapBindingMsg: 'bindingMsg0 -> 'bindingMsg) (inMapBindingViewModel: 'vm0 -> 'vm) (d: SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'vm, 'vmCollection>) = { GetModels = d.GetModels >> Seq.map outMapBindingModel CreateViewModel = fun args -> d.CreateViewModel(args |> ViewModelArgs.map inMapBindingModel outMapBindingMsg) |> outMapBindingViewModel - CreateCollection = Seq.map inMapBindingViewModel >> d.CreateCollection >> CollectionTarget.map outMapBindingViewModel outMapBindingVmCollection inMapBindingViewModel + CreateCollection = Seq.map inMapBindingViewModel >> d.CreateCollection >> CollectionTarget.mapA outMapBindingViewModel inMapBindingViewModel UpdateViewModel = fun (vm, m) -> d.UpdateViewModel (inMapBindingViewModel vm, inMapBindingModel m) ToMsg = fun m (idx, bMsg) -> d.ToMsg m (idx, (inMapBindingMsg bMsg)) } - let boxMinorTypes d = d |> mapMinorTypes box box box box unbox unbox unbox + let boxMinorTypes d = d |> mapMinorTypes box box box unbox unbox unbox let create createViewModel updateViewModel = { GetModels = (fun x -> upcast x) @@ -685,7 +765,6 @@ module BindingData = (outMapBindingModel: 'bindingModel -> 'bindingModel0) (outMapBindingMsg: 'bindingMsg -> 'bindingMsg0) (outMapBindingViewModel: 'vm -> 'vm0) - (outMapBindingVmCollection: 'vmCollection -> 'vmCollection0) (outMapId: 'id -> 'id0) (inMapBindingModel: 'bindingModel0 -> 'bindingModel) (inMapBindingMsg: 'bindingMsg0 -> 'bindingMsg) @@ -694,14 +773,14 @@ module BindingData = (d: SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'vm, 'vmCollection, 'id>) = { GetSubModels = d.GetSubModels >> Seq.map outMapBindingModel CreateViewModel = fun args -> d.CreateViewModel(args |> ViewModelArgs.map inMapBindingModel outMapBindingMsg) |> outMapBindingViewModel - CreateCollection = Seq.map inMapBindingViewModel >> d.CreateCollection >> CollectionTarget.map outMapBindingViewModel outMapBindingVmCollection inMapBindingViewModel + CreateCollection = Seq.map inMapBindingViewModel >> d.CreateCollection >> CollectionTarget.mapA outMapBindingViewModel inMapBindingViewModel UpdateViewModel = fun (vm, m) -> (inMapBindingViewModel vm, inMapBindingModel m) |> d.UpdateViewModel ToMsg = fun m (id, bMsg) -> d.ToMsg m ((inMapId id), (inMapBindingMsg bMsg)) BmToId = inMapBindingModel >> d.BmToId >> outMapId VmToId = fun vm -> vm |> inMapBindingViewModel |> d.VmToId |> outMapId } - let boxMinorTypes d = d |> mapMinorTypes box box box box box unbox unbox unbox unbox + let boxMinorTypes d = d |> mapMinorTypes box box box box unbox unbox unbox unbox let create createViewModel updateViewModel bmToId vmToId = { GetSubModels = (fun x -> upcast x) diff --git a/src/Elmish.WPF/DynamicViewModel.fs b/src/Elmish.WPF/DynamicViewModel.fs index 31a2493e..32845b60 100644 --- a/src/Elmish.WPF/DynamicViewModel.fs +++ b/src/Elmish.WPF/DynamicViewModel.fs @@ -20,7 +20,7 @@ module internal Helpers = let createBinding data name = { Name = name - Data = data } + Data = data |> BindingData.boxT } type SubModelSelectedItemLast with member this.CompareBindings() : Binding<'model, 'msg> -> Binding<'model, 'msg> -> int = diff --git a/src/Elmish.WPF/Merge.fs b/src/Elmish.WPF/Merge.fs index 262705eb..264a810c 100644 --- a/src/Elmish.WPF/Merge.fs +++ b/src/Elmish.WPF/Merge.fs @@ -42,7 +42,7 @@ module CollectionTarget = Enumerate = fun () -> upcast oc GetCollection = fun () -> oc } - let private mapA (fOut: 'a0 -> 'a1) (fIn: 'a1 -> 'a0) (ct: CollectionTarget<'a0, 'aCollection>) : CollectionTarget<'a1, 'aCollection> = + let mapA (fOut: 'a0 -> 'a1) (fIn: 'a1 -> 'a0) (ct: CollectionTarget<'a0, 'aCollection>) : CollectionTarget<'a1, 'aCollection> = { GetLength = ct.GetLength GetAt = ct.GetAt >> fOut Append = fIn >> ct.Append @@ -54,7 +54,7 @@ module CollectionTarget = Enumerate = ct.Enumerate >> Seq.map fOut GetCollection = ct.GetCollection } - let private mapCollection (fOut: 'aCollection0 -> 'aCollection1) (ct: CollectionTarget<'a, 'aCollection0>) : CollectionTarget<'a, 'aCollection1> = + let mapCollection (fOut: 'aCollection0 -> 'aCollection1) (ct: CollectionTarget<'a, 'aCollection0>) : CollectionTarget<'a, 'aCollection1> = { GetLength = ct.GetLength GetAt = ct.GetAt Append = ct.Append @@ -66,10 +66,6 @@ module CollectionTarget = Enumerate = ct.Enumerate GetCollection = ct.GetCollection >> fOut } - let map outMapA outMapCollection inMapA = - mapA outMapA inMapA - >> mapCollection outMapCollection - module Merge = From fc313b0f2b0265218bb8cd7106c5861cbe72912d Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Sat, 6 Aug 2022 15:37:40 -0500 Subject: [PATCH 2/5] Remove redundant boxes --- src/Elmish.WPF/Binding.fs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Elmish.WPF/Binding.fs b/src/Elmish.WPF/Binding.fs index 7cbf2905..59c8c55c 100644 --- a/src/Elmish.WPF/Binding.fs +++ b/src/Elmish.WPF/Binding.fs @@ -91,7 +91,6 @@ module Binding = /// Elemental instance of a one-way binding. let id<'a, 'msg> : string -> Binding<'a, 'msg> = OneWay.id - |> BindingData.mapModel box |> createBinding /// Creates a one-way binding to an optional value. The binding @@ -114,7 +113,6 @@ module Binding = /// Elemental instance of a one-way-to-source binding. let id<'model, 'a> : string -> Binding<'model, 'a> = OneWayToSource.id - |> BindingData.mapMsg unbox |> createBinding /// Creates a one-way-to-source binding to an optional value. The binding @@ -137,8 +135,6 @@ module Binding = /// Elemental instance of a two-way binding. let id<'a> : string -> Binding<'a, 'a> = TwoWay.id - |> BindingData.mapModel box - |> BindingData.mapMsg unbox |> createBinding /// Creates a one-way-to-source binding to an optional value. The binding From 404c358b73e1934b4ea6ecbbad113393e6fc84d7 Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Sat, 6 Aug 2022 15:44:29 -0500 Subject: [PATCH 3/5] Add type constraint for commands --- src/Elmish.WPF/BindingData.fs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Elmish.WPF/BindingData.fs b/src/Elmish.WPF/BindingData.fs index 1358f9bc..fef07ff6 100644 --- a/src/Elmish.WPF/BindingData.fs +++ b/src/Elmish.WPF/BindingData.fs @@ -3,6 +3,7 @@ module internal Elmish.WPF.BindingData open System.Collections.ObjectModel open System.Windows +open System.Windows.Input open Elmish @@ -552,7 +553,7 @@ module BindingData = module Cmd = - let createWithParam exec canExec autoRequery : BindingData<'model, 'msg, 't> = + let createWithParam exec canExec autoRequery : BindingData<'model, 'msg, ICommand> = { Exec = exec CanExec = canExec AutoRequery = autoRequery } From 091dd4e7a31a1ec126e3f4690ba6a0262a936548 Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Thu, 8 Dec 2022 09:57:48 -0600 Subject: [PATCH 4/5] Add unboxed Binding type --- src/Elmish.WPF/DynamicViewModel.fs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/Elmish.WPF/DynamicViewModel.fs b/src/Elmish.WPF/DynamicViewModel.fs index 32845b60..bc0c7b9e 100644 --- a/src/Elmish.WPF/DynamicViewModel.fs +++ b/src/Elmish.WPF/DynamicViewModel.fs @@ -9,10 +9,12 @@ open Microsoft.Extensions.Logging open BindingVmHelpers /// Represents all necessary data used to create a binding. -type Binding<'model, 'msg> = +type Binding<'model, 'msg, 't> = internal { Name: string - Data: BindingData<'model, 'msg, obj> } + Data: BindingData<'model, 'msg, 't> } + +type Binding<'model, 'msg> = Binding<'model, 'msg, obj> [] @@ -22,6 +24,10 @@ module internal Helpers = { Name = name Data = data |> BindingData.boxT } + let createBindingT data name = + { Name = name + Data = data } + type SubModelSelectedItemLast with member this.CompareBindings() : Binding<'model, 'msg> -> Binding<'model, 'msg> -> int = fun a b -> this.Recursive(a.Data) - this.Recursive(b.Data) From ce0a646af71c582e9fcd4aebbd5fee87f53d5d92 Mon Sep 17 00:00:00 2001 From: Joshua Marner Date: Thu, 8 Dec 2022 18:25:49 -0600 Subject: [PATCH 5/5] Add public box/unbox for Binding<> types --- src/Elmish.WPF/Binding.fs | 6 ++++++ src/Elmish.WPF/BindingData.fs | 1 + 2 files changed, 7 insertions(+) diff --git a/src/Elmish.WPF/Binding.fs b/src/Elmish.WPF/Binding.fs index 59c8c55c..122ad6d0 100644 --- a/src/Elmish.WPF/Binding.fs +++ b/src/Elmish.WPF/Binding.fs @@ -12,6 +12,12 @@ module Binding = { Name = binding.Name Data = binding.Data |> f } + /// Boxes the output parameter + let boxT (binding: Binding<'b, 'msg, 't>) = BindingData.boxT |> mapData <| binding + + /// Unboxes the output parameter + let unboxT (binding: Binding<'b, 'msg>): Binding<'b, 'msg, 't> = BindingData.unboxT |> mapData <| binding + /// Maps the model of a binding via a contravariant mapping. let mapModel (f: 'a -> 'b) (binding: Binding<'b, 'msg>) = f |> mapModel |> mapData <| binding diff --git a/src/Elmish.WPF/BindingData.fs b/src/Elmish.WPF/BindingData.fs index fef07ff6..40d893ff 100644 --- a/src/Elmish.WPF/BindingData.fs +++ b/src/Elmish.WPF/BindingData.fs @@ -245,6 +245,7 @@ module BindingData = } let boxT b = MapT.recursiveCase box unbox b + let unboxT b = MapT.recursiveCase unbox box b let mapModel f = let binaryHelper binary x m = binary x (f m)