format aperture in backtrack trace

[scpubgit/DX.git] / lib / DX / Utils.pm

package DX::Utils;

use strictures 2;
use List::UtilsBy qw(sort_by);
use Exporter 'import';

my @const = (
  my @dep_types = qw(CONTENTS_OF INDICES_OF TYPE_OF EXISTENCE_OF),
  my @ev_types = qw(VALUE_SET VALUE_EXISTS),
);

our @EXPORT_OK = (
  @const,
  (my @builders = qw(rspace rstrat res string number dict proposition)),
  'deparse', '*trace', 'expand_deps', 'format_deps', 'compact_deps',
);

our %EXPORT_TAGS = (
  all => \@EXPORT_OK,
  dep_types => \@dep_types,
  event_types => \@ev_types,
  builders => \@builders,
);

require constant;

# use constant INDICES_OF => \*INDICES_OF;

constant->import(+{
  map {; no strict 'refs'; $_ => \*$_ } @const
});

# $CONTENTS_OF = 1, ... # stronger dependency has lower number

do { no strict 'refs'; ${$dep_types[$_-1]} = $_ } for 1..@dep_types;

# VALUE_EXISTS needs to trigger indices checks on its parent

our $VALUE_EXISTS = 1;

# VALUE_EXISTS triggers all types, VALUE_SET all but EXISTENCE_OF

our @VALUE_EXISTS = (EXISTENCE_OF(), TYPE_OF(), INDICES_OF(), CONTENTS_OF());
our @VALUE_SET = (TYPE_OF(), INDICES_OF(), CONTENTS_OF());

sub trace { }

sub _expand_dep {
  my ($type, @path) = @{$_[0]};
  my @expanded = map {
    ref() ? @{$_->value_path or return ()} : $_
  } @path;
  return [ $type, @expanded ];
}

sub expand_deps {
  [ map _expand_dep($_), @{$_[0]} ]
}

sub format_deps {
  [ block => [
      map [ statement => [
        [ symbol => (split '::', ${$_->[0]})[-1] ],
        [ value_path => [ @{$_}[1..$#$_] ] ]
      ] ], @{$_[0]}
  ] ]
}

sub compact_deps {
  my ($deps) = @_;
  my @sorted = sort_by { join "\0", @{$_->[0]} }
                 map { [ [ join("\0", @{$_}[1..$#$_], ''), $${$_->[0]} ], $_ ] } @$deps;
  my @compacted;
  while (my $s = shift @sorted) {
    my ($path, $type) = @{$s->[0]};
    shift @sorted while @sorted and $sorted[0][0][0] eq $path;
    if ($type == 1) { # CONTENTS_OF dep, prune children
      my $len = length($path);
      shift @sorted while @sorted and substr($sorted[0][0][0], 0, $len) eq $path;
    }
    if ($type == 2) { # INDICES_OF dep, drop immediately below EXISTENCE_OF
      my $len = length($path);
      my $parts = @{$s->[1]} + 1;
      my @keep;
      while (@sorted and substr($sorted[0][0][0], 0, $len) eq $path) {
        my $check = shift @sorted;
        unless ($check->[0][1] == 4 and @{$check->[1]} == $parts) {
          push @keep, $check;
        }
      }
      unshift @sorted, @keep;
    }
    push @compacted, $s->[1];
  }
  return \@compacted;
}

sub rspace {
  require DX::ResolutionSpace;
  DX::ResolutionSpace->new(@_);
}

sub rstrat {
  require DX::ResolutionStrategy;
  DX::ResolutionStrategy->new(@_);
}

sub res {
  require DX::Resolution;
  DX::Resolution->new(@_);
}

sub string {
  require DX::Value::String;
  DX::Value::String->new(string_value => $_[0])
}

sub number {
  require DX::Value::Number;
  DX::Value::Number->new(number_value => $_[0]);
}

sub dict {
  require DX::Value::Dict;
  DX::Value::Dict->new(
    members => { @_ },
  );
}

sub proposition {
  my ($pred, @args) = @_;
  require DX::Proposition;
  DX::Proposition->new(
    predicate => $pred,
    args => \@args,
  );
}

{
  my $dp;

  sub deparse {
    $dp ||= do {
      require DX::TraceFormatter;
      DX::TraceFormatter->new;
    };
    my ($thing) = @_;
    $dp->format($thing);
  }
}

1;