Skip to content

Commit

Permalink
Add mapvm function for bindingdata and use it
Browse files Browse the repository at this point in the history
  • Loading branch information
@marner2
marner2 committed Jun 14, 2022
1 parent a1403d2 commit 4e7ef03
Show file tree
Hide file tree
Showing 5 changed files with 147 additions and 51 deletions.
6 changes: 3 additions & 3 deletions src/Elmish.WPF/Binding.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -92,7 +92,7 @@ module Binding =

/// Elemental instance of a one-way binding.
let id<'a, 'msg> : string -> Binding<'a, 'msg> =
create box
create id
|> createBinding

/// Creates a one-way binding to an optional value. The binding
Expand All @@ -115,7 +115,7 @@ module Binding =

/// Elemental instance of a one-way-to-source binding.
let id<'model, 'a> : string -> Binding<'model, 'a> =
create (fun obj _ -> obj |> unbox)
create (fun obj _ -> obj)
|> createBinding

/// Creates a one-way-to-source binding to an optional value. The binding
Expand All @@ -138,7 +138,7 @@ module Binding =

/// Elemental instance of a two-way binding.
let id<'a> : string -> Binding<'a, 'a> =
create box (fun obj _ -> obj |> unbox)
create id (fun obj _ -> obj)
|> createBinding

/// Creates a one-way-to-source binding to an optional value. The binding
Expand Down
142 changes: 113 additions & 29 deletions src/Elmish.WPF/BindingData.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,13 +25,13 @@ type internal OneWayToSourceData<'model, 'msg, 'a> =
{ Set: 'a -> 'model -> 'msg }


type internal OneWaySeqData<'model, 'a, 'id when 'id : equality> =
type internal OneWaySeqData<'model, 'a, 'vmCollection, 'id when 'id : equality> =
{ Get: 'model -> 'a seq
CreateCollection: 'a seq -> CollectionTarget<'a>
CreateCollection: 'a seq -> CollectionTarget<'a, 'vmCollection>
GetId: 'a -> 'id
ItemEquals: 'a -> 'a -> bool }

member d.Merge(values: CollectionTarget<'a>, newModel: 'model) =
member d.Merge(values: CollectionTarget<'a, 'vmCollection>, newModel: 'model) =
let create v _ = v
let update oldVal newVal oldIdx =
if not (d.ItemEquals newVal oldVal) then
Expand Down Expand Up @@ -77,18 +77,18 @@ and internal SubModelWinData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingV
}


and internal SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel> =
and internal SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'vmCollection> =
{ GetModels: 'model -> 'bindingModel seq
CreateViewModel: ViewModelArgs<'bindingModel,'bindingMsg> -> 'bindingViewModel
CreateCollection: 'bindingViewModel seq -> CollectionTarget<'bindingViewModel>
CreateCollection: 'bindingViewModel seq -> CollectionTarget<'bindingViewModel, 'vmCollection>
UpdateViewModel: 'bindingViewModel * 'bindingModel -> unit
ToMsg: 'model -> int * 'bindingMsg -> 'msg }


and internal SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'id when 'id : equality> =
and internal SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'vmCollection, 'id when 'id : equality> =
{ GetSubModels: 'model -> 'bindingModel seq
CreateViewModel: ViewModelArgs<'bindingModel,'bindingMsg> -> 'bindingViewModel
CreateCollection: 'bindingViewModel seq -> CollectionTarget<'bindingViewModel>
CreateCollection: 'bindingViewModel seq -> CollectionTarget<'bindingViewModel, 'vmCollection>
UpdateViewModel: 'bindingViewModel * 'bindingModel -> unit
GetUnderlyingModel: 'bindingViewModel -> 'bindingModel
ToMsg: 'model -> 'id * 'bindingMsg -> 'msg
Expand All @@ -98,7 +98,7 @@ and internal SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bin
(getTargetId: ('bindingModel -> 'id) -> 't -> 'id,
create: 'bindingModel -> 'id -> 't,
update: 't -> 'bindingModel -> unit,
values: CollectionTarget<'t>,
values: CollectionTarget<'t, 'vmCollection>,
newSubModels: 'bindingModel []) =
let update t bm _ = update t bm
Merge.keyed d.GetId (getTargetId d.GetId) create update values newSubModels
Expand Down Expand Up @@ -139,13 +139,13 @@ and internal AlterMsgStreamData<'model, 'msg, 'bindingModel, 'bindingMsg, 'dispa
and internal BaseBindingData<'model, 'msg, 'a> =
| OneWayData of OneWayData<'model, 'a>
| OneWayToSourceData of OneWayToSourceData<'model, 'msg, 'a>
| OneWaySeqData of OneWaySeqData<'model, obj, obj>
| OneWaySeqData of OneWaySeqData<'model, obj, 'a, obj>
| TwoWayData of TwoWayData<'model, 'msg, 'a>
| CmdData of CmdData<'model, 'msg>
| SubModelData of SubModelData<'model, 'msg, obj, obj, 'a>
| SubModelWinData of SubModelWinData<'model, 'msg, obj, obj, 'a>
| SubModelSeqUnkeyedData of SubModelSeqUnkeyedData<'model, 'msg, obj, obj, obj>
| SubModelSeqKeyedData of SubModelSeqKeyedData<'model, 'msg, obj, obj, obj, obj>
| SubModelSeqUnkeyedData of SubModelSeqUnkeyedData<'model, 'msg, obj, obj, obj, 'a>
| SubModelSeqKeyedData of SubModelSeqKeyedData<'model, 'msg, obj, obj, obj, 'a, obj>
| SubModelSelectedItemData of SubModelSelectedItemData<'model, 'msg, obj>


Expand All @@ -160,6 +160,94 @@ and internal BindingData<'model, 'msg, 'a> =

module internal BindingData =


module private VmMapperHelpers =

let baseCase (fOut: 'a -> 'b) (fIn: 'b -> 'a) =
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.mapVm 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.mapVm fOut
UpdateViewModel = d.UpdateViewModel
ToMsg = d.ToMsg
}
| SubModelSeqKeyedData d -> SubModelSeqKeyedData {
GetSubModels = d.GetSubModels
CreateViewModel = d.CreateViewModel
CreateCollection = d.CreateCollection >> CollectionTarget.mapVm fOut
UpdateViewModel = d.UpdateViewModel
GetUnderlyingModel = d.GetUnderlyingModel
ToMsg = d.ToMsg
GetId = d.GetId
}
| SubModelSelectedItemData d -> SubModelSelectedItemData {
Get = d.Get
Set = d.Set
SubModelSeqBindingName = d.SubModelSeqBindingName
}
let rec recursiveCase<'model, 'msg, 'a, 'b> (fOut: 'a -> 'b) (fIn: 'b -> 'a) : BindingData<'model, 'msg, 'a> -> BindingData<'model, 'msg, 'b> =
function
| BaseBindingData d -> d |> baseCase fOut fIn |> BaseBindingData
| CachingData d -> d |> recursiveCase<'model, 'msg, 'a, 'b> fOut fIn |> CachingData
| ValidationData d -> ValidationData {
BindingData = recursiveCase<'model, 'msg, 'a, 'b> fOut fIn d.BindingData
Validate = d.Validate
}
| LazyData d -> LazyData {
Get = d.Get
Set = d.Set
BindingData = recursiveCase<obj, obj, 'a, 'b> fOut fIn d.BindingData
Equals = d.Equals
}
| AlterMsgStreamData d ->
let x = d.BindingData
AlterMsgStreamData {
BindingData = recursiveCase<obj, obj, 'a, 'b> fOut fIn x
AlterMsgStream = d.AlterMsgStream
Get = d.Get
Set = d.Set
}

let mapVm (fOut: 'a -> 'b) (fIn: 'b -> 'a): BindingData<'model, 'msg, 'a> -> BindingData<'model, 'msg, 'b> =
VmMapperHelpers.recursiveCase fOut fIn

let mapModel f =
let binaryHelper binary x m = binary x (f m)
let baseCase = function
Expand Down Expand Up @@ -405,7 +493,7 @@ module internal BindingData =
(outMapA: 'a -> 'a0)
(outMapId: 'id -> 'id0)
(inMapA: 'a0 -> 'a)
(d: OneWaySeqData<'model, 'a, 'id>) = {
(d: OneWaySeqData<'model, 'a, 'vmCollection, 'id>) = {
Get = d.Get >> Seq.map outMapA
CreateCollection = Seq.map inMapA >> d.CreateCollection >> CollectionTarget.map outMapA inMapA
GetId = inMapA >> d.GetId >> outMapId
Expand All @@ -418,7 +506,7 @@ module internal BindingData =
mGet
mGetId
mItemEquals
(d: OneWaySeqData<'model, 'a, 'id>) =
(d: OneWaySeqData<'model, 'a, 'vmCollection, 'id>) =
{ d with Get = mGet d.Get
GetId = mGetId d.GetId
ItemEquals = mItemEquals d.ItemEquals }
Expand Down Expand Up @@ -482,7 +570,7 @@ module internal BindingData =
(mCanExec "canExec")


let createWithParam exec canExec autoRequery : BindingData<'model, 'msg> =
let createWithParam exec canExec autoRequery : BindingData<'model, 'msg, ICommand> =
{ Exec = exec
CanExec = canExec
AutoRequery = autoRequery }
Expand Down Expand Up @@ -519,7 +607,7 @@ module internal BindingData =
(mSet "set")

let create (get: 'model -> 'id voption) (set: 'id voption -> 'model -> 'msg) subModelSeqBindingName
: BindingData<'model, 'msg> =
: BindingData<'model, 'msg, 'a> =
{ Get = get
Set = set
SubModelSeqBindingName = subModelSeqBindingName }
Expand All @@ -533,18 +621,16 @@ module internal BindingData =
let mapMinorTypes
(outMapBindingModel: 'bindingModel -> 'bindingModel0)
(outMapBindingMsg: 'bindingMsg -> 'bindingMsg0)
(outMapBindingViewModel: 'bindingViewModel -> 'bindingViewModel0)
(inMapBindingModel: 'bindingModel0 -> 'bindingModel)
(inMapBindingMsg: 'bindingMsg0 -> 'bindingMsg)
(inMapBindingViewModel: 'bindingViewModel0 -> 'bindingViewModel)
(d: SubModelData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel>) = {
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 = mapMinorTypes box box box unbox unbox unbox d
let boxMinorTypes d = mapMinorTypes box box unbox unbox d

let mapFunctions
mGetModel
Expand Down Expand Up @@ -579,21 +665,19 @@ module internal BindingData =
let mapMinorTypes
(outMapBindingModel: 'bindingModel -> 'bindingModel0)
(outMapBindingMsg: 'bindingMsg -> 'bindingMsg0)
(outMapBindingViewModel: 'bindingViewModel -> 'bindingViewModel0)
(inMapBindingModel: 'bindingModel0 -> 'bindingModel)
(inMapBindingMsg: 'bindingMsg0 -> 'bindingMsg)
(inMapBindingViewModel: 'bindingViewModel0 -> 'bindingViewModel)
(d: SubModelWinData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel>) = {
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 box d = mapMinorTypes box box box unbox unbox unbox d
let box d = mapMinorTypes box box unbox unbox d

let mapFunctions
mGetState
Expand Down Expand Up @@ -641,7 +725,7 @@ module internal BindingData =
(inMapBindingModel: 'bindingModel0 -> 'bindingModel)
(inMapBindingMsg: 'bindingMsg0 -> 'bindingMsg)
(inMapBindingViewModel: 'bindingViewModel0 -> 'bindingViewModel)
(d: SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel>) = {
(d: SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, '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 inMapBindingViewModel
Expand All @@ -655,7 +739,7 @@ module internal BindingData =
mGetModels
mGetBindings
mToMsg
(d: SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel>) =
(d: SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'vmCollection>) =
{ d with GetModels = mGetModels d.GetModels
CreateViewModel = mGetBindings d.CreateViewModel
ToMsg = mToMsg d.ToMsg }
Expand Down Expand Up @@ -691,7 +775,7 @@ module internal BindingData =
(inMapBindingMsg: 'bindingMsg0 -> 'bindingMsg)
(inMapBindingViewModel: 'bindingViewModel0 -> 'bindingViewModel)
(inMapId: 'id0 -> 'id)
(d: SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'id>) = {
(d: SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, '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 inMapBindingViewModel
Expand All @@ -708,7 +792,7 @@ module internal BindingData =
mGetBindings
mToMsg
mGetId
(d: SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'id>) =
(d: SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'vmCollection, 'id>) =
{ d with GetSubModels = mGetSubModels d.GetSubModels
CreateViewModel = mGetBindings d.CreateViewModel
ToMsg = mToMsg d.ToMsg
Expand Down
24 changes: 12 additions & 12 deletions src/Elmish.WPF/BindingVmHelpers.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -94,9 +94,9 @@ type OneWayToSourceBinding<'model, 'a> = {
Set: 'a -> 'model -> unit
}

type OneWaySeqBinding<'model, 'a, 'id when 'id : equality> = {
OneWaySeqData: OneWaySeqData<'model, 'a, 'id>
Values: CollectionTarget<'a>
type OneWaySeqBinding<'model, 'a, 'vmCollection, 'id when 'id : equality> = {
OneWaySeqData: OneWaySeqData<'model, 'a, 'vmCollection, 'id>
Values: CollectionTarget<'a, 'vmCollection>
}

type TwoWayBinding<'model, 'a> = {
Expand All @@ -116,14 +116,14 @@ type SubModelWinBinding<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewMo
VmWinState: WindowState<'bindingViewModel> ref
}

type SubModelSeqUnkeyedBinding<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel> = {
SubModelSeqUnkeyedData: SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel>
Vms: CollectionTarget<'bindingViewModel>
type SubModelSeqUnkeyedBinding<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'vmCollection> = {
SubModelSeqUnkeyedData: SubModelSeqUnkeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'vmCollection>
Vms: CollectionTarget<'bindingViewModel, 'vmCollection>
}

type SubModelSeqKeyedBinding<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'id when 'id : equality> =
{ SubModelSeqKeyedData: SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'id>
Vms: CollectionTarget<'bindingViewModel> }
type SubModelSeqKeyedBinding<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'vmCollection, 'id when 'id : equality> =
{ SubModelSeqKeyedData: SubModelSeqKeyedData<'model, 'msg, 'bindingModel, 'bindingMsg, 'bindingViewModel, 'vmCollection, 'id>
Vms: CollectionTarget<'bindingViewModel, 'vmCollection> }

member d.FromId(id: 'id) =
d.Vms.Enumerate ()
Expand Down Expand Up @@ -153,13 +153,13 @@ type SubModelSelectedItemBinding<'model, 'msg, 'bindingModel, 'bindingMsg, 'bind
type BaseVmBinding<'model, 'msg, 'a> =
| OneWay of OneWayBinding<'model, 'a>
| OneWayToSource of OneWayToSourceBinding<'model, 'a>
| OneWaySeq of OneWaySeqBinding<'model, obj, obj>
| OneWaySeq of OneWaySeqBinding<'model, obj, 'a, obj>
| TwoWay of TwoWayBinding<'model, 'a>
| Cmd of cmd: Command
| SubModel of SubModelBinding<'model, 'msg, obj, obj, 'a>
| SubModelWin of SubModelWinBinding<'model, 'msg, obj, obj, 'a>
| SubModelSeqUnkeyed of SubModelSeqUnkeyedBinding<'model, 'msg, obj, obj, obj>
| SubModelSeqKeyed of SubModelSeqKeyedBinding<'model, 'msg, obj, obj, obj, obj>
| SubModelSeqUnkeyed of SubModelSeqUnkeyedBinding<'model, 'msg, obj, obj, obj, 'a>
| SubModelSeqKeyed of SubModelSeqKeyedBinding<'model, 'msg, obj, obj, obj, 'a, obj>
| SubModelSelectedItem of SubModelSelectedItemBinding<'model, 'msg, obj, obj, 'a, obj>


Expand Down
2 changes: 1 addition & 1 deletion src/Elmish.WPF/DynamicViewModel.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ module internal Helpers =

let createBinding data name =
{ Name = name
Data = data }
Data = data |> BindingData.mapVm box unbox }

type SubModelSelectedItemLast with
member this.CompareBindings() : Binding<'model, 'msg> -> Binding<'model, 'msg> -> int =
Expand Down
Loading

0 comments on commit 4e7ef03

Please sign in to comment.