150 / 162 lines covered (92.6%)
12unit module BDD::Behave::Diff;34use nqp;5use BDD::Behave::Colors;67proto sub is-junction($) is export {*}8multi sub is-junction(Junction:D --> Bool) { True }9multi sub is-junction($ --> Bool) { False }1011sub diff-shape($value) is export {12 return 'Undef' unless $value.defined;13 given $value {14 when Str { 'Str' }15 when Mix | MixHash { 'Mix' }16 when Bag | BagHash { 'Bag' }17 when Set | SetHash { 'Set' }18 when Associative { 'Hash' }19 when Positional { 'Array' }20 default { 'Scalar' }21 }22}2324proto sub diffable($, $) is export {*}25multi sub diffable($, Junction:D --> Bool) { True }26multi sub diffable($given, $expected --> Bool) {27 return False unless $given.defined && $expected.defined;28 my $sg = diff-shape($given);29 return False unless $sg eq diff-shape($expected);30 so $sg eq any(<Str Array Hash Set Bag Mix>);31}3233proto sub render-diff(|) is export {*}34multi sub render-diff($given, Junction:D $expected, Bool :$negated = False --> Str) {35 junction-diff($given, $expected, :$negated);36}37multi sub render-diff($given, $expected, Bool :$negated = False --> Str) {38 given diff-shape($given) {39 when 'Str' { string-diff($given, $expected) }40 default { structural-diff($given, $expected) }41 }42}4344sub string-diff(Str:D $given, Str:D $expected --> Str) {45 if $given.contains("\n") || $expected.contains("\n") {46 return line-level-diff($expected.lines.list, $given.lines.list);47 }48 char-level-diff($given, $expected);49}5051sub char-level-diff(Str:D $given, Str:D $expected --> Str) {52 my @g = $given.comb;53 my @e = $expected.comb;5455 my $prefix = 0;56 while $prefix < @g.elems && $prefix < @e.elems57 && @g[$prefix] eq @e[$prefix] {58 $prefix++;59 }6061 my $g-end = @g.elems;62 my $e-end = @e.elems;63 while $g-end > $prefix && $e-end > $prefix64 && @g[$g-end - 1] eq @e[$e-end - 1] {65 $g-end--;66 $e-end--;67 }6869 my $common-pre = $given.substr(0, $prefix);70 my $g-mid = $given.substr($prefix, $g-end - $prefix);71 my $g-suf = $given.substr($g-end);72 my $e-mid = $expected.substr($prefix, $e-end - $prefix);73 my $e-suf = $expected.substr($e-end);7475 my $e-line = '- ' ~ "'" ~ $common-pre76 ~ ($e-mid.chars ?? red($e-mid) !! '')77 ~ $e-suf ~ "'";78 my $g-line = '+ ' ~ "'" ~ $common-pre79 ~ ($g-mid.chars ?? green($g-mid) !! '')80 ~ $g-suf ~ "'";8182 $e-line ~ "\n" ~ $g-line;83}8485sub line-level-diff(@expected-lines, @given-lines --> Str) {86 my @ops = lcs-diff(@expected-lines.list, @given-lines.list);87 my @out;88 for @ops -> $op {89 my ($kind, $line) = @$op;90 given $kind {91 when '=' { @out.push: ' ' ~ $line }92 when '-' { @out.push: red('- ' ~ $line) }93 when '+' { @out.push: green('+ ' ~ $line) }94 }95 }96 @out.join("\n");97}9899sub structural-diff($given, $expected --> Str) {100 line-level-diff(pretty-lines($expected), pretty-lines($given));101}102103sub pretty-lines($value, Int :$indent = 0 --> List) is export {104 my $pad = ' ' x $indent;105 given diff-shape($value) {106 when 'Hash' { hash-pretty($value, $indent) }107 when 'Array' { array-pretty($value, $indent) }108 when 'Set' { set-pretty($value, $indent) }109 when 'Bag' { bag-pretty($value, $indent, 'Bag') }110 when 'Mix' { bag-pretty($value, $indent, 'Mix') }111 default { ($pad ~ scalar-repr($value),).List }112 }113}114115sub scalar-repr($value --> Str) {116 return 'Nil' unless $value.defined;117 $value ~~ Str ?? $value.raku !! $value.gist;118}119120sub format-key($k --> Str) {121 $k ~~ Str ?? $k.raku !! $k.gist;122}123124sub hash-pretty($value, Int $indent --> List) {125 my $pad = ' ' x $indent;126 my $inner = ' ' x ($indent + 2);127 my @keys = $value.keys.sort(*.gist);128 return ($pad ~ '{}',).List unless @keys;129 my @lines = $pad ~ '{';130 for @keys -> $k {131 my @sub = pretty-lines($value{$k}, :indent($indent + 2));132 @sub[0] = $inner ~ format-key($k) ~ ' => ' ~ @sub[0].substr($indent + 2);133 @sub[*-1] ~= ',';134 @lines.append: @sub;135 }136 @lines.push: $pad ~ '}';137 @lines.List;138}139140sub array-pretty($value, Int $indent --> List) {141 my $pad = ' ' x $indent;142 return ($pad ~ '[]',).List unless $value.elems;143 my @lines = $pad ~ '[';144 for $value.list -> $v {145 my @sub = pretty-lines($v, :indent($indent + 2));146 @sub[*-1] ~= ',';147 @lines.append: @sub;148 }149 @lines.push: $pad ~ ']';150 @lines.List;151}152153sub set-pretty($value, Int $indent --> List) {154 my $pad = ' ' x $indent;155 my $inner = ' ' x ($indent + 2);156 my @keys = $value.keys.map(*.gist).sort;157 return ($pad ~ 'Set()',).List unless @keys;158 my @lines = $pad ~ 'Set(';159 for @keys -> $k {160 @lines.push: $inner ~ $k ~ ',';161 }162 @lines.push: $pad ~ ')';163 @lines.List;164}165166sub bag-pretty($value, Int $indent, Str $name --> List) {167 my $pad = ' ' x $indent;168 my $inner = ' ' x ($indent + 2);169 my @entries = $value.pairs.map({ format-key(.key) ~ ' => ' ~ .value }).sort;170 return ($pad ~ $name ~ '()',).List unless @entries;171 my @lines = $pad ~ $name ~ '(';172 for @entries -> $e {173 @lines.push: $inner ~ $e ~ ',';174 }175 @lines.push: $pad ~ ')';176 @lines.List;177}178179sub junction-kind(Junction:D $j --> Str) is export {180 nqp::box_s(nqp::getattr_s(nqp::decont($j), Junction, q|$!type|), Str);181}182183sub junction-eigenstates(Junction:D $j --> List) is export {184 my $e := nqp::getattr(nqp::decont($j), Junction, q|$!eigenstates|);185 (^nqp::elems($e)).map({ nqp::atpos($e, $_) }).list;186}187188sub junction-member-repr($v --> Str) {189 $v.defined ?? $v.raku !! $v.^name;190}191192sub junction-summary(Str $kind, Int $matched, Int $total, Bool $negated --> Str) {193 given $kind {194 when 'any' {195 $negated196 ?? "Alternatives ($matched of $total matched; expected none under negation):"197 !! "Alternatives (none of $total matched; expected at least one):"198 }199 when 'all' {200 $negated201 ?? "Alternatives ($matched of $total matched; expected at least one to fail under negation):"202 !! "Alternatives ($matched of $total matched; expected all):"203 }204 when 'one' {205 $negated206 ?? "Alternatives ($matched of $total matched; expected zero or more than one under negation):"207 !! "Alternatives ($matched of $total matched; expected exactly one):"208 }209 when 'none' {210 $negated211 ?? "Alternatives ($matched of $total matched; expected at least one under negation):"212 !! "Alternatives ($matched of $total matched; expected zero):"213 }214 default {215 "Alternatives ($matched of $total matched):"216 }217 }218}219220sub junction-diff($given, Junction:D $expected, Bool :$negated = False --> Str) is export {221 my $kind = junction-kind($expected);222 my @members = junction-eigenstates($expected);223 my @results = @members.map({ so ($given ~~ $_) });224 my $matched = @results.grep(*.so).elems;225226 my @lines;227 @lines.push: red('- ' ~ $expected.gist);228 @lines.push: green('+ ' ~ scalar-repr($given));229 @lines.push: ' ' ~ junction-summary($kind, $matched, @members.elems, $negated);230 for @members.kv -> $i, $m {231 my $hit = @results[$i];232 my $mark = $hit ?? green('✓') !! red('✗');233 @lines.push: " $mark " ~ junction-member-repr($m);234 }235 @lines.join("\n");236}237238sub lcs-diff(@a, @b --> List) {239 my $m = @a.elems;240 my $n = @b.elems;241242 my @t;243 for 0..$m -> $i { @t[$i][0] = 0; }244 for 0..$n -> $j { @t[0][$j] = 0; }245 for 1..$m -> $i {246 for 1..$n -> $j {247 if @a[$i-1] eq @b[$j-1] {248 @t[$i][$j] = @t[$i-1][$j-1] + 1;249 } else {250 @t[$i][$j] = @t[$i-1][$j] >= @t[$i][$j-1]251 ?? @t[$i-1][$j]252 !! @t[$i][$j-1];253 }254 }255 }256257 my @ops;258 my ($i, $j) = $m, $n;259 while $i > 0 && $j > 0 {260 if @a[$i-1] eq @b[$j-1] {261 @ops.unshift: ['=', @a[$i-1]];262 $i--; $j--;263 } elsif @t[$i-1][$j] > @t[$i][$j-1] {264 @ops.unshift: ['-', @a[$i-1]];265 $i--;266 } else {267 @ops.unshift: ['+', @b[$j-1]];268 $j--;269 }270 }271 while $i > 0 { @ops.unshift: ['-', @a[$i-1]]; $i--; }272 while $j > 0 { @ops.unshift: ['+', @b[$j-1]]; $j--; }273274 @ops.List;275}