diff options
author | Yorhel <git@yorhel.nl> | 2020-03-15 08:20:59 +0100 |
---|---|---|
committer | Yorhel <git@yorhel.nl> | 2020-03-15 08:21:01 +0100 |
commit | 74aad378d49592df4359ea8a9f6f36d4a0013c04 (patch) | |
tree | c8a92557a5ac11728d49c3ae01d0d065c9ab5248 | |
parent | 6a5a93013e8e7254d8c91faf9e6fadde7cbb8d08 (diff) |
TUWF::Validate::Interp::elm_decoder(): Support structs with more than 8 fields
-rw-r--r-- | lib/TUWF/Validate/Interop.pm | 51 |
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; |