./TravEpi/SimpleRulesBase/Rules.pm
package MGH_Biostat::TravEpi::SimpleRulesBase::Rules;
use Modern::Perl;
use experimental 'switch';
use Carp;
use JSON;
use File::Slurp qw(slurp read_dir);
use Try::Tiny;
use Set::Tiny qw(set);
use List::MoreUtils qw(all any);
use MGH_Biostat::TravEpi::SimpleRulesBase::DynamicText;
use Package::Alias 'M_B::Countries' => 'MGH_Biostat::TravEpi::SimpleRulesBase::Countries';
my $test_combiners = {
'any' => \&any,
'all' => \&all,
};
sub new {
my $class = shift;
my $self = {};
my $valid_test_combiners = set( 'any', 'all' );
foreach my $f ( read_dir("rules") ) {
next unless $f =~ m/(.+)\.rule/;
my $rule_name = $1;
try {
$self->{$rule_name} = _convert_into_sets( decode_json( scalar( slurp("rules/$f") ) ) );
$self->{$rule_name}{'key'} = $rule_name;
}
catch {
# if it is a non-empty file, warn about the file being non-valid JSON
if ( -s "rules/$f" ) {
if ( $_ =~ m/malformed JSON string/ ) {
warn("$rule_name: could not parse file: $_");
}
else {
die "$f: " . $_;
}
}
};
if ( defined( $self->{$rule_name}{'test-combiner'} ) ) {
if ( !$valid_test_combiners->element( $self->{$rule_name}{'test-combiner'} ) ) {
die("$rule_name: test combiner '$self->{$rule_name}{'test-combiner'}' invalid\n");
}
}
else {
$self->{$rule_name}{'test-combiner'} = 'any';
}
}
# verify that all rules are valid
no autovivification;
my @missing_rule_errors = ();
foreach my $rule_name ( keys %$self ) {
my $rule = $self->{$rule_name};
if ( exists( $rule->{'subrules'} ) ) {
foreach my $subrule_name ( @{ $rule->{'subrules'} } ) {
if ( !exists( $self->{$subrule_name} ) ) {
push @missing_rule_errors, "Error in $rule_name: subrule $subrule_name doesn't exist";
}
}
}
}
if (@missing_rule_errors) {
die( "Errors:\n" . join( "\n" => @missing_rule_errors ) . "\n" );
}
# verify that all countries are valid, and remap them if they are
no autovivification;
my @country_errors = ();
foreach my $rule_name ( keys %$self ) {
my $rule = $self->{$rule_name};
if ( exists( $rule->{'tests'} ) ) {
foreach my $test ( @{ $rule->{'tests'} } ) {
if ( exists( $test->{'variable'} ) and ( $test->{'variable'} eq 'dests' ) ) {
my $invalid = $test->{'values'}->difference( M_B::Countries::valid_countries() );
if ( $invalid->is_empty() ) {
$test->{'values'} = M_B::Countries::mapped_countries( $test->{'values'} );
}
else {
push @country_errors, "Error in $rule_name: invalid country(s) " . join( ", " => sort $invalid->elements() );
}
}
}
}
}
if (@country_errors) {
die( "Errors:\n" . join( "\n" => @country_errors ) . "\n" );
}
return bless $self, $class;
}
sub _convert_into_sets {
my ($rule) = @_;
no autovivification;
if ( exists( $rule->{'tests'} ) ) {
foreach my $test ( @{ $rule->{'tests'} } ) {
if ( exists( $test->{'values'} ) ) {
$test->{'values'} = set( $test->{'values'} );
}
}
}
return $rule;
}
sub get_rule_names {
my $self = shift;
return keys %{$self};
}
sub get_rule {
my $self = shift;
my ($name) = @_;
no autovivification;
if ( exists( $self->{$name} ) ) {
return $self->{$name};
}
else {
croak("undefined rule $name requested");
}
}
# Rule handling
sub process_rule {
my $self = shift;
my ( $rulename, $params, $datatree ) = @_;
my $rule = $self->get_rule($rulename);
my $passed_tests = [];
if ( defined( $rule->{'tests'} ) ) {
$passed_tests = [ map { $self->_run_test( $_, $params ); } @{ $rule->{'tests'} } ];
}
else {
# emulate a test that always passes
$passed_tests = [ 1 ];
}
# @TODO this is ugly. can it be made better?
my $combiner = $rule->{'test-combiner'} // 'any';
if ( $test_combiners->{$combiner}->( sub { $_ }, @$passed_tests ) ) {
my $subtree = {};
foreach my $imports ( grep { ref($_) eq 'HASH' } @$passed_tests ) {
$subtree = { %$subtree, %$imports };
}
if ( defined( $rule->{'subrules'} ) ) {
foreach my $subrule ( @{ $rule->{'subrules'} } ) {
$self->process_rule( $subrule, $params, $subtree );
}
}
$datatree->{ $rule->{'key'} } = $subtree;
}
else {
$datatree->{ $rule->{'key'} } = '';
}
if ( $rule->{'child-precedence'} ) {
my $subtree = $datatree->{ $rule->{'key'} };
my $found = 0;
foreach my $c ( @{ $rule->{'child-precedence'} } ) {
if ( !$found and exists( $subtree->{$c} ) and ( ref( $subtree->{$c} ) eq 'HASH' ) ) {
$found = 1;
}
elsif ( $found and exists( $subtree->{$c} ) ) {
$subtree->{$c} = '';
}
}
}
if ( $rule->{'remove-if'} ) {
my $subtree = $datatree->{ $rule->{'key'} };
if ( ref($subtree) eq 'HASH' ) {
if ( $rule->{'remove-if'}{'no-children'} ) {
my $children = grep { ref( $subtree->{$_} ) eq 'HASH' } keys %$subtree;
if ( !$children ) {
$datatree->{ $rule->{'key'} } = '';
}
}
if ( $rule->{'remove-if'}{'missing-children'} ) {
my $children = grep { ref( $subtree->{$_} ) eq 'HASH' } @{ $rule->{'remove-if'}{'missing-children'} };
if ( !$children ) {
$datatree->{ $rule->{'key'} } = '';
}
}
}
}
}
sub _run_test {
my $self = shift;
my ( $test, $params ) = @_;
# this needs to be here so that we don't falsely fail due to a missing "variable" key
given ( $test->{'test'} ) {
when ('true') { return 1; }
when ('false') { return 0; }
}
my $variable_value = $params->{ $test->{'variable'} };
if ( !defined($variable_value) ) {
return 0;
}
given ( $test->{'test'} ) {
when ('>=') {
return $variable_value >= $test->{'with'};
}
when ('<=') {
return $variable_value <= $test->{'with'};
}
when ('>') {
return $variable_value > $test->{'with'};
}
when ('<') {
return $variable_value < $test->{'with'};
}
when ('=') {
return $variable_value == $test->{'with'};
}
when ('eq') {
return $variable_value eq $test->{'with'};
}
when ('intersects') {
## double !! is effectively a coercion to boolean
my $intersection = $variable_value->intersection( $test->{'values'} );
my $passed = !!( $intersection->size() );
if ( $passed and exists( $test->{'intersect-values-to'} ) ) {
my $def = $test->{'intersect-values-to'};
my $type = $def->{'type'} || $variable_value;
my $context = $def->{'context'} || {};
return { $def->{'token'} => newdt( $type, $intersection, $context ) };
}
else {
return $passed;
}
}
when ('excludes') {
my $difference = $variable_value->difference( $test->{'values'} );
my $passed = !!( $difference->size() );
if ( $passed and exists( $test->{'intersect-values-to'} ) ) {
my $def = $test->{'intersect-values-to'};
my $type = $def->{'type'} || $variable_value;
my $context = $def->{'context'} || {};
return { $def->{'token'} => newdt( $type, $difference, $context ) };
}
else {
return $passed;
}
}
when ('disjoints') {
return $variable_value->is_disjoint( $test->{'values'} );
}
default {
return 0;
}
}
}
# process the rules, generating a description instead of running tests
# note that this returns a tree with HTML embedded!
sub describe_rule {
no autovivification;
my $self = shift;
my ($rulename) = @_;
my $rule = $self->get_rule($rulename);
my $tree = { '_rule' => '' };
$tree->{'_rule'} .= '<div class="rule-explanation" id="rule-' . $rulename . '">';
$tree->{'_rule'} .= '<p class="rule-name">' . $rulename . '</p>';
if ( defined( $rule->{'tests'} ) ) {
$tree->{'_rule'} .= '<p class="tests-title">Tests (' . $rule->{'test-combiner'} . '):</p><ol class="tests">';
foreach my $test ( @{ $rule->{'tests'} } ) {
$tree->{'_rule'} .= '<li>' . $self->_describe_test($test) . '</li>';
if ( defined( $test->{'intersect-values-to'} ) ) {
$tree->{ $test->{'intersect-values-to'}{'token'} } = '[intersecting or disjoint elements]';
}
}
$tree->{'_rule'} .= '</ol>';
}
if ( defined( $rule->{'child-precedence'} ) ) {
$tree->{'_rule'} .= '<p class="child-precedence">Only the first of these rules to be true will be displayed: '
. '<span class="subrule-list">' . join( ", " => @{ $rule->{'child-precedence'} } ) . '</span>'
. '</p>';
}
if ( defined( $rule->{'remove-if'} ) ) {
$tree->{'_rule'} .= '<p class="remove-if">'
. 'This rule will be removed if'
. ( defined( $rule->{'remove-if'}{'no-children'} ) ? ' no subrules pass' : '' )
. ( defined( $rule->{'remove-if'}{'missing-children'} ) ? ' none of the following subrules are present: ' . join( ", " => map { '<kbd>' . $_ . '</kbd>' } @{ $rule->{'remove-if'}{'missing-children'} } ) : '' )
. '</p>';
}
$tree->{'_rule'} .= '</div>';
if ( defined( $rule->{'subrules'} ) ) {
foreach my $subrule ( @{ $rule->{'subrules'} } ) {
$tree->{$subrule} = $self->describe_rule($subrule);
}
}
return $tree;
}
sub _describe_test {
my $self = shift;
my ($test) = @_;
given ( $test->{'test'} ) {
when ('true') {
return "This test is always true";
}
when ('false') {
return "This test is always false";
}
when ('>=') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">≥</span> <span class=\"value\">$test->{'with'}</span>";
}
when ('<=') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">≤</span> <span class=\"value\">$test->{'with'}</span>";
}
when ('>') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">></span> <span class=\"value\">$test->{'with'}</span>";
}
when ('<') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\"><</span> <span class=\"value\">$test->{'with'}</span>";
}
when ('=') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">=</span> <span class=\"value\">$test->{'with'}</span>";
}
when ('eq') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">matches as a string with</span> <span class=\"value\">$test->{'with'}</span>";
}
when ('intersects') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test intersect\">intersects the set</span> <span class=\"value set intersection\">" . join( ", " => sort $test->{'values'}->elements() ) . '</span>';
}
when ('excludes') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test exclude\">has elements not in the set</span> <span class=\"value set exclusion\">" . join( ", " => sort $test->{'values'}->elements() ) . '</span>';
}
when ('disjoints') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test disjoint\">is disjoint from the set</span> <span class=\"value set disjunction\">" . join( ", " => sort $test->{'values'}->elements() ) . '</span>';
}
default {
return "There is no test here; move along (something weird is going on).";
}
}
}
1;