TUWF::Validate::Interp::elm_decoder(): Support structs with more than 8 fields

1 files changed, 39 insertions, 12 deletions

diff --git a/lib/TUWF/Validate/Interop.pm b/lib/TUWF/Validate/Interop.pm
index 047bd71..cc2d1c0 100644
--- a/lib/TUWF/Validate/Interop.pm
+++ b/lib/TUWF/Validate/Interop.pm
@@ -248,21 +248,48 @@ sub elm_decoder {
     my $len = 0;
     $len = length $_ > $len ? length $_ : $len for keys %{$o->{keys}};
 
+    my $r;
     my $num = keys %{$o->{keys}};
     my $varnum = 1;
-    croak 'Unable to decode maps with more than 8 members' if $num > 8;
-
-    my(@fnarg, @assign, @fetch);
-    for (sort keys %{$o->{keys}}) {
-      my $var = $opt{var_prefix}.($varnum++);
-      push @fnarg, $var;
-      push @assign, "$_ = $var";
-      push @fetch, sprintf '(%sfield "%s"%s %s)', $opt{json_decode}, $_,
-        ' 'x($len-(length $_)),
-        $opt{keys}{$_} || $o->{keys}{$_}->elm_decoder(%opt, var_prefix => $var, level => $opt{level}+1);
+    my $getvar = sub { $opt{var_prefix}.($varnum++) };
+
+    # For 8 members or less we can use the simple Json.Decode.map* functions.
+    if($num <= 8) {
+      my(@fnarg, @assign, @fetch);
+      for (sort keys %{$o->{keys}}) {
+        my $var = $getvar->();
+        push @fnarg, $var;
+        push @assign, "$_ = $var";
+        push @fetch, sprintf '(%sfield "%s"%s %s)', $opt{json_decode}, $_,
+          ' 'x($len-(length $_)),
+          $opt{keys}{$_} || $o->{keys}{$_}->elm_decoder(%opt, var_prefix => $var, level => $opt{level}+1);
+      }
+      $r = sprintf "(%smap%d\n(\\%s -> { %s })\n%s)",
+        $opt{json_decode}, $num, join(' ', @fnarg), join(', ', @assign), join("\n", @fetch);
+
+    # For larger hashes we go through Json.Decode.dict and a little custom decoding logic.
+    # Json.Decode only allows failing with an error string, so the error messages aren't as good.
+    } else {
+      my($dict, $fn, $name, $dec, $next, $cap) = map $getvar->(), 1..6;
+      my(@assign, @fn);
+      for (sort keys %{$o->{keys}}) {
+        my $var = $getvar->();
+        push @assign, "$_ = $var";
+        push @fn, sprintf '%s "%s"%s %s (\%s ->', $fn, $_,
+          ' 'x($len-(length $_)),
+          $opt{keys}{$_} || $o->{keys}{$_}->elm_decoder(%opt, var_prefix => "${var}_", level => $opt{level}+1),
+          $var;
+      }
+      my $spc = ' 'x(12 + length($fn) + length($name) + length($dec) + length($next));
+      $r = "($opt{json_decode}andThen (\\$dict -> \n"
+          ."let $fn $name $dec $next = case Maybe.map ($opt{json_decode}decodeValue $dec) (Dict.get $name $dict) of\n"
+          ."${spc}Nothing -> $opt{json_decode}fail (\"Missing key '\"++$name++\"'\")\n"
+          ."${spc}Just (Err $cap) -> $opt{json_decode}fail (\"Error decoding value of '\"++$name++\"': \"++($opt{json_decode}errorToString $cap))\n"
+          ."${spc}Just (Ok $cap) -> $next $cap\n"
+          ."in ".join("\n   ", @fn)."\n"
+          ."   $opt{json_decode}succeed { ".join(', ', @assign)." }\n"
+          .')'.(')'x@fn)." ($opt{json_decode}dict $opt{json_decode}value))";
     }
-    my $r = sprintf "(%smap%d\n(\\%s -> { %s })\n%s)",
-      $opt{json_decode}, $num, join(' ', @fnarg), join(', ', @assign), join("\n", @fetch);
 
     $r =~ s/\n/$opt{indent} ? "\n" . (' 'x($opt{indent}*$opt{level})) : ''/eg;
     return $r;