From 60d71cca7d88f326b86673747b2fc6595303c662 Mon Sep 17 00:00:00 2001
From: Tyson Williams <tyson.williams@blocherconsulting.com>
Date: Wed, 30 Dec 2020 10:56:11 -0600
Subject: [PATCH] added support for multiple validation errors #314

---
 src/Elmish.WPF.Tests/ViewModelTests.fs       |   2 +-
 src/Elmish.WPF/Binding.fs                    | 121 ++++++++++++++++---
 src/Elmish.WPF/ViewModel.fs                  |  35 +++---
 src/Samples/Validation.Views/MainWindow.xaml |  38 +++++-
 src/Samples/Validation/Program.fs            |  43 +++++--
 5 files changed, 182 insertions(+), 57 deletions(-)

diff --git a/src/Elmish.WPF.Tests/ViewModelTests.fs b/src/Elmish.WPF.Tests/ViewModelTests.fs
index 8641f868..b419a502 100644
--- a/src/Elmish.WPF.Tests/ViewModelTests.fs
+++ b/src/Elmish.WPF.Tests/ViewModelTests.fs
@@ -153,7 +153,7 @@ module Helpers =
     name |> createBinding (TwoWayValidateData {
       Get = get >> box
       Set = unbox<'a> >> set
-      Validate = validate
+      Validate = validate >> ValueOption.toList
       WrapDispatch = id
     })
 
diff --git a/src/Elmish.WPF/Binding.fs b/src/Elmish.WPF/Binding.fs
index 0b9cc516..987ec995 100644
--- a/src/Elmish.WPF/Binding.fs
+++ b/src/Elmish.WPF/Binding.fs
@@ -60,7 +60,7 @@ type internal TwoWayData<'model, 'msg, 'a> = {
 type internal TwoWayValidateData<'model, 'msg, 'a> = {
   Get: 'model -> 'a
   Set: 'a -> 'model -> 'msg
-  Validate: 'model -> string voption
+  Validate: 'model -> string list
   WrapDispatch: Dispatch<'msg> -> Dispatch<'msg>
 }
 
@@ -565,6 +565,33 @@ type Binding private () =
     } |> createBinding
 
 
+  /// <summary>
+  ///   Creates a two-way binding with validation using
+  ///   <c>INotifyDataErrorInfo</c>.
+  /// </summary>
+  /// <param name="get">Gets the value from the model.</param>
+  /// <param name="set">Returns the message to dispatch.</param>
+  /// <param name="validate">
+  ///   Returns the validation messages from the updated model.
+  /// </param>
+  /// <param name="wrapDispatch">
+  ///   Wraps the dispatch function with additional behavior, such as
+  ///   throttling, debouncing, or limiting.
+  /// </param>
+  static member twoWayValidate
+      (get: 'model -> 'a,
+       set: 'a -> 'model -> 'msg,
+       validate: 'model -> string list,
+       ?wrapDispatch: Dispatch<'msg> -> Dispatch<'msg>)
+      : string -> Binding<'model, 'msg> =
+    TwoWayValidateData {
+      Get = get >> box
+      Set = unbox<'a> >> set
+      Validate = validate
+      WrapDispatch = defaultArg wrapDispatch id
+    } |> createBinding
+
+
   /// <summary>
   ///   Creates a two-way binding with validation using
   ///   <c>INotifyDataErrorInfo</c>.
@@ -587,7 +614,7 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> box
       Set = unbox<'a> >> set
-      Validate = validate
+      Validate = validate >> ValueOption.toList
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -614,7 +641,7 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> box
       Set = unbox<'a> >> set
-      Validate = validate >> ValueOption.ofOption
+      Validate = validate >> Option.toList
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -641,7 +668,7 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> box
       Set = unbox<'a> >> set
-      Validate = validate >> ValueOption.ofError
+      Validate = validate >> ValueOption.ofError >> ValueOption.toList
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -670,7 +697,7 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> ValueOption.map box >> ValueOption.toObj
       Set = ValueOption.ofObj >> ValueOption.map unbox<'a> >> set
-      Validate = validate
+      Validate = validate >> ValueOption.toList
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -699,7 +726,7 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> ValueOption.map box >> ValueOption.toObj
       Set = ValueOption.ofObj >> ValueOption.map unbox<'a> >> set
-      Validate = validate >> ValueOption.ofOption
+      Validate = validate >> Option.toList
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -728,7 +755,36 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> ValueOption.map box >> ValueOption.toObj
       Set = ValueOption.ofObj >> ValueOption.map unbox<'a> >> set
-      Validate = validate >> ValueOption.ofError
+      Validate = validate >> ValueOption.ofError >> ValueOption.toList
+      WrapDispatch = defaultArg wrapDispatch id
+    } |> createBinding
+
+
+  /// <summary>
+  ///   Creates a two-way binding to an optional value with validation using
+  ///   <c>INotifyDataErrorInfo</c>. The binding automatically converts between
+  ///   the optional source value and an unwrapped (possibly <c>null</c>) value
+  ///   on the view side.
+  /// </summary>
+  /// <param name="get">Gets the value from the model.</param>
+  /// <param name="set">Returns the message to dispatch.</param>
+  /// <param name="validate">
+  ///   Returns the validation messages from the updated model.
+  /// </param>
+  /// <param name="wrapDispatch">
+  ///   Wraps the dispatch function with additional behavior, such as
+  ///   throttling, debouncing, or limiting.
+  /// </param>
+  static member twoWayOptValidate
+      (get: 'model -> 'a option,
+       set: 'a option -> 'model -> 'msg,
+       validate: 'model -> string list,
+       ?wrapDispatch: Dispatch<'msg> -> Dispatch<'msg>)
+      : string -> Binding<'model, 'msg> =
+    TwoWayValidateData {
+      Get = get >> Option.map box >> Option.toObj
+      Set = Option.ofObj >> Option.map unbox<'a> >> set
+      Validate = validate
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -757,7 +813,7 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> Option.map box >> Option.toObj
       Set = Option.ofObj >> Option.map unbox<'a> >> set
-      Validate = validate
+      Validate = validate >> ValueOption.toList
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -786,7 +842,7 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> Option.map box >> Option.toObj
       Set = Option.ofObj >> Option.map unbox<'a> >> set
-      Validate = validate >> ValueOption.ofOption
+      Validate = validate >> Option.toList
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -815,7 +871,7 @@ type Binding private () =
     TwoWayValidateData {
       Get = get >> Option.map box >> Option.toObj
       Set = Option.ofObj >> Option.map unbox<'a> >> set
-      Validate = validate >> ValueOption.ofError
+      Validate = validate >> ValueOption.ofError >> ValueOption.toList
       WrapDispatch = defaultArg wrapDispatch id
     } |> createBinding
 
@@ -1965,6 +2021,33 @@ module Extensions =
       } |> createBinding
 
 
+    /// <summary>
+    ///   Creates a two-way binding with validation using
+    ///   <c>INotifyDataErrorInfo</c>.
+    /// </summary>
+    /// <param name="get">Gets the value from the model.</param>
+    /// <param name="set">Returns the message to dispatch.</param>
+    /// <param name="validate">
+    ///   Returns the validation messages from the updated model.
+    /// </param>
+    /// <param name="wrapDispatch">
+    ///   Wraps the dispatch function with additional behavior, such as
+    ///   throttling, debouncing, or limiting.
+    /// </param>
+    static member twoWayValidate
+        (get: 'model -> 'a,
+         set: 'a -> 'msg,
+         validate: 'model -> string list,
+         ?wrapDispatch: Dispatch<'msg> -> Dispatch<'msg>)
+        : string -> Binding<'model, 'msg> =
+      TwoWayValidateData {
+        Get = get >> box
+        Set = fun p _ -> p |> unbox<'a> |> set
+        Validate = validate
+        WrapDispatch = defaultArg wrapDispatch id
+      } |> createBinding
+
+
     /// <summary>
     ///   Creates a two-way binding with validation using
     ///   <c>INotifyDataErrorInfo</c>.
@@ -1987,7 +2070,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> box
         Set = fun p _ -> p |> unbox<'a> |> set
-        Validate = validate
+        Validate = validate >> ValueOption.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
@@ -2014,7 +2097,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> box
         Set = fun p  _ -> p |> unbox<'a> |> set
-        Validate = validate >> ValueOption.ofOption
+        Validate = validate >> Option.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
@@ -2041,7 +2124,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> box
         Set = fun p _ -> p |> unbox<'a> |> set
-        Validate = validate >> ValueOption.ofError
+        Validate = validate >> ValueOption.ofError >> ValueOption.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
@@ -2070,7 +2153,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> ValueOption.map box >> ValueOption.toObj
         Set = fun p _ -> p |> ValueOption.ofObj |> ValueOption.map unbox<'a> |> set
-        Validate = validate
+        Validate = validate >> ValueOption.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
@@ -2099,7 +2182,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> ValueOption.map box >> ValueOption.toObj
         Set = fun p _ -> p |> ValueOption.ofObj |> ValueOption.map unbox<'a> |> set
-        Validate = validate >> ValueOption.ofOption
+        Validate = validate >> Option.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
@@ -2128,7 +2211,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> ValueOption.map box >> ValueOption.toObj
         Set = fun p _ -> p |> ValueOption.ofObj |> ValueOption.map unbox<'a> |> set
-        Validate = validate >> ValueOption.ofError
+        Validate = validate >> ValueOption.ofError >> ValueOption.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
@@ -2157,7 +2240,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> Option.map box >> Option.toObj
         Set = fun p _ -> p |> Option.ofObj |> Option.map unbox<'a> |> set
-        Validate = validate
+        Validate = validate >> ValueOption.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
@@ -2186,7 +2269,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> Option.map box >> Option.toObj
         Set = fun p _ -> p |> Option.ofObj |> Option.map unbox<'a> |> set
-        Validate = validate >> ValueOption.ofOption
+        Validate = validate >> Option.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
@@ -2215,7 +2298,7 @@ module Extensions =
       TwoWayValidateData {
         Get = get >> Option.map box >> Option.toObj
         Set = fun p _ -> p |> Option.ofObj |> Option.map unbox<'a> |> set
-        Validate = validate >> ValueOption.ofError
+        Validate = validate >> ValueOption.ofError >> ValueOption.toList
         WrapDispatch = defaultArg wrapDispatch id
       } |> createBinding
 
diff --git a/src/Elmish.WPF/ViewModel.fs b/src/Elmish.WPF/ViewModel.fs
index 74f2d161..97022215 100644
--- a/src/Elmish.WPF/ViewModel.fs
+++ b/src/Elmish.WPF/ViewModel.fs
@@ -205,7 +205,7 @@ type internal TwoWayBinding<'model, 'msg, 'a> = {
 type internal TwoWayValidateBinding<'model, 'msg, 'a> = {
   Get: 'model -> 'a
   Set: 'a -> 'model -> unit
-  Validate: 'model -> string voption
+  Validate: 'model -> string list
 }
 
 type internal CmdBinding<'model, 'msg> = {
@@ -284,7 +284,7 @@ and [<AllowNullLiteral>] internal ViewModel<'model, 'msg>
   let errorsChanged = DelegateEvent<EventHandler<DataErrorsChangedEventArgs>>()
 
   /// Error messages keyed by property name.
-  let errors = Dictionary<string, string>()
+  let errorsByBindingName = Dictionary<string, string list>()
 
 
   let withCaching b = Cached { Binding = b; Cache = ref None }
@@ -309,24 +309,17 @@ and [<AllowNullLiteral>] internal ViewModel<'model, 'msg>
   let raiseCanExecuteChanged (cmd: Command) =
     cmd.RaiseCanExecuteChanged ()
 
-  let setError error propName =
-    match errors.TryGetValue propName with
-    | true, err when err = error -> ()
-    | _ ->
-        log "[%s] ErrorsChanged \"%s\"" propNameChain propName
-        errors.[propName] <- error
-        errorsChanged.Trigger([| box this; box <| DataErrorsChangedEventArgs propName |])
-
-  let removeError propName =
-    if errors.Remove propName then
-      log "[%s] ErrorsChanged \"%s\"" propNameChain propName
-      errorsChanged.Trigger([| box this; box <| DataErrorsChangedEventArgs propName |])
-
   let rec updateValidationError model name = function
     | TwoWayValidate { Validate = validate } ->
-        match validate model with
-        | ValueNone -> removeError name
-        | ValueSome error -> setError error name
+        let oldErrors =
+          match errorsByBindingName.TryGetValue name with
+          | (true, errors) -> errors
+          | (false, _) -> []
+        let newErrors = validate model
+        if oldErrors <> newErrors then
+          log "[%s] ErrorsChanged \"%s\"" propNameChain name
+          errorsByBindingName.[name] <- newErrors
+          errorsChanged.Trigger([| box this; box <| DataErrorsChangedEventArgs name |])
     | OneWay _
     | OneWayLazy _
     | OneWaySeq _
@@ -831,9 +824,9 @@ and [<AllowNullLiteral>] internal ViewModel<'model, 'msg>
     [<CLIEvent>]
     member __.ErrorsChanged = errorsChanged.Publish
     member __.HasErrors =
-      errors.Count > 0
+      errorsByBindingName.Count > 0
     member __.GetErrors propName =
       log "[%s] GetErrors %s" propNameChain (propName |> Option.ofObj |> Option.defaultValue "<null>")
-      match errors.TryGetValue propName with
-      | true, err -> upcast [err]
+      match errorsByBindingName.TryGetValue propName with
+      | true, errs -> upcast errs
       | false, _ -> upcast []
diff --git a/src/Samples/Validation.Views/MainWindow.xaml b/src/Samples/Validation.Views/MainWindow.xaml
index 14042104..aafb5559 100644
--- a/src/Samples/Validation.Views/MainWindow.xaml
+++ b/src/Samples/Validation.Views/MainWindow.xaml
@@ -1,4 +1,4 @@
-<Window x:Class="Elmish.WPF.Samples.Validation.MainWindow"
+<Window x:Class="Elmish.WPF.Samples.Validation.MainWindow"
         xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
         xmlns:d="http://schemas.microsoft.com/expression/blend/2008"
         xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
@@ -11,7 +11,7 @@
         mc:Ignorable="d"
         d:DataContext="{x:Static vm:Program.designVm}">
   <Window.Resources>
-    <Style x:Key="textBoxInError" TargetType="Control">
+    <Style x:Key="textBoxInErrorSingle" TargetType="Control">
       <Setter Property="Validation.ErrorTemplate">
         <Setter.Value>
           <ControlTemplate>
@@ -34,9 +34,37 @@
         </Trigger>
       </Style.Triggers>
     </Style>
+    <Style x:Key="textBoxInErrorMultiple" TargetType="Control">
+      <Setter Property="Validation.ErrorTemplate">
+        <Setter.Value>
+          <ControlTemplate>
+            <DockPanel>
+              <TextBlock DockPanel.Dock="Left" Foreground="Red" FontWeight="Bold">*</TextBlock>
+              <ItemsControl DockPanel.Dock="Bottom" ItemsSource="{Binding ElementName=placeholder, Path=AdornedElement.(Validation.Errors)}">
+                <ItemsControl.ItemTemplate>
+                  <DataTemplate>
+                    <TextBlock Text="{Binding ErrorContent}" Foreground="Red"/>
+                  </DataTemplate>
+                </ItemsControl.ItemTemplate>
+              </ItemsControl>
+              <Border BorderBrush="Red" BorderThickness="2">
+                <AdornedElementPlaceholder x:Name="placeholder"/>
+              </Border>
+            </DockPanel>
+          </ControlTemplate>
+        </Setter.Value>
+      </Setter>
+    </Style>
   </Window.Resources>
-  <StackPanel Margin="0,25,0,0">
-    <TextBox Style="{StaticResource textBoxInError}" Text="{Binding RawValue, UpdateSourceTrigger=PropertyChanged}" Width="150" Margin="0,5,0,25" />
-    <Button Command="{Binding Submit}" Content="Submit" Margin="0,5,10,5" Width="50" />
+  <StackPanel HorizontalAlignment="Center" Margin="0,25,0,0">
+    <StackPanel Orientation="Horizontal">
+      <TextBlock Text="Value:         "/>
+      <TextBox Style="{StaticResource textBoxInErrorSingle}"   Text="{Binding Value,    UpdateSourceTrigger=PropertyChanged}" Width="150" Margin="0,5,0,25" />
+    </StackPanel>
+    <StackPanel Orientation="Horizontal">
+      <TextBlock Text="Password:   "/>
+      <TextBox Style="{StaticResource textBoxInErrorMultiple}" Text="{Binding Password, UpdateSourceTrigger=PropertyChanged}" Width="150" Margin="0,5,0,25" />
+    </StackPanel>
+    <Button Command="{Binding Submit}" Content="Submit" Margin="0,40,10,5" Width="50" />
   </StackPanel>
 </Window>
diff --git a/src/Samples/Validation/Program.fs b/src/Samples/Validation/Program.fs
index 2210e01c..d9350de1 100644
--- a/src/Samples/Validation/Program.fs
+++ b/src/Samples/Validation/Program.fs
@@ -1,6 +1,7 @@
 module Elmish.WPF.Samples.Validation.Program
 
 open System
+open System.Linq
 open Elmish
 open Elmish.WPF
 
@@ -22,28 +23,48 @@ let validateInt42 =
   >> Result.bind (requireExactly 42)
 
 
+let validatePassword (s: string) =
+  seq {
+    if s.All(fun c -> Char.IsDigit c |> not) then
+      "Must contain a digit"
+    if s.All(fun c -> Char.IsLower c |> not) then
+      "Must contain a lowercase letter"
+    if s.All(fun c -> Char.IsUpper c |> not) then
+      "Must contain an uppercase letter"
+  } |> Seq.toList
+
+
 type Model =
-  { RawValue: string }
+  { Value: string
+    Password: string }
 
 let init () =
-  { RawValue = "" }
+  { Value = ""
+    Password = "" }
 
 type Msg =
-  | Input of string
-  | Submit of int
+  | NewValue of string
+  | NewPassword of string
+  | Submit
 
 let update msg m =
   match msg with
-  | Input x -> { m with RawValue = x }
-  | Submit _ -> m
+  | NewValue x -> { m with Value = x }
+  | NewPassword x -> { m with Password = x }
+  | Submit -> m
 
 let bindings () : Binding<Model, Msg> list = [
-  "RawValue" |> Binding.twoWayValidate(
-    (fun m -> m.RawValue),
-    Input,
-    (fun m ->  validateInt42 m.RawValue))
+  "Value" |> Binding.twoWayValidate(
+    (fun m -> m.Value),
+    NewValue,
+    (fun m ->  validateInt42 m.Value))
+  "Password" |> Binding.twoWayValidate(
+    (fun m -> m.Password),
+    NewPassword,
+    (fun m -> validatePassword m.Password))
   "Submit" |> Binding.cmdIf(
-    fun m -> validateInt42 m.RawValue |> Result.map Submit)
+    (fun _ -> Submit),
+    (fun m -> (match validateInt42 m.Value with Ok _ -> true | Error _ -> false) && (validatePassword m.Password |> List.isEmpty)))
 ]
 
 let designVm = ViewModel.designInstance (init ()) (bindings ())