lib/DX/Utils.pm

   1 package DX::Utils;
   2
   3 use strictures 2;
   4 use List::UtilsBy qw(sort_by);
   5 use Exporter 'import';
   6
   7 my @const = (
   8   my @dep_types = qw(CONTENTS_OF INDICES_OF TYPE_OF EXISTENCE_OF),
   9   my @ev_types = qw(VALUE_SET VALUE_EXISTS),
  10 );
  11
  12 our @EXPORT_OK = (
  13   @const,
  14   (my @builders = qw(rspace rstrat res string number dict proposition)),
  15   'deparse', '*trace', 'expand_deps', 'format_deps', 'compact_deps',
  16 );
  17
  18 our %EXPORT_TAGS = (
  19   all => \@EXPORT_OK,
  20   dep_types => \@dep_types,
  21   event_types => \@ev_types,
  22   builders => \@builders,
  23 );
  24
  25 require constant;
  26
  27 # use constant INDICES_OF => \*INDICES_OF;
  28
  29 constant->import(+{
  30   map {; no strict 'refs'; $_ => \*$_ } @const
  31 });
  32
  33 # $CONTENTS_OF = 1, ... # stronger dependency has lower number
  34
  35 do { no strict 'refs'; ${$dep_types[$_-1]} = $_ } for 1..@dep_types;
  36
  37 # VALUE_EXISTS needs to trigger indices checks on its parent
  38
  39 our $VALUE_EXISTS = 1;
  40
  41 # VALUE_EXISTS triggers all types, VALUE_SET all but EXISTENCE_OF
  42
  43 our @VALUE_EXISTS = (EXISTENCE_OF(), TYPE_OF(), INDICES_OF(), CONTENTS_OF());
  44 our @VALUE_SET = (TYPE_OF(), INDICES_OF(), CONTENTS_OF());
  45
  46 sub trace { }
  47
  48 sub _expand_dep {
  49   my ($type, @path) = @{$_[0]};
  50   my @expanded = map {
  51     ref() ? @{$_->value_path or return ()} : $_
  52   } @path;
  53   return [ $type, @expanded ];
  54 }
  55
  56 sub expand_deps {
  57   [ map _expand_dep($_), @{$_[0]} ]
  58 }
  59
  60 sub format_deps {
  61   [ block => [
  62       map [ statement => [
  63         [ symbol => (split '::', ${$_->[0]})[-1] ],
  64         [ value_path => [ @{$_}[1..$#$_] ] ]
  65       ] ], @{$_[0]}
  66   ] ]
  67 }
  68
  69 sub compact_deps {
  70   my ($deps) = @_;
  71   my @sorted = sort_by { join "\0", @{$_->[0]} }
  72                  map { [ [ join("\0", @{$_}[1..$#$_]), $${$_->[0]} ], $_ ] } @$deps;
  73   my @compacted;
  74   while (my $s = shift @sorted) {
  75     my ($path, $type) = @{$s->[0]};
  76     shift @sorted while @sorted and $sorted[0][0][0] eq $path;
  77     if ($type == 1) { # CONTENTS_OF dep, prune children
  78       my $len = length($path);
  79       shift @sorted while @sorted and substr($sorted[0][0][0], 0, $len) eq $path;
  80     }
  81     if ($type == 2) { # INDICES_OF dep, drop immediately below EXISTENCE_OF
  82       my $len = length($path);
  83       my $parts = @{$s->[1]} + 1;
  84       my @keep;
  85       while (@sorted and substr($sorted[0][0][0], 0, $len) eq $path) {
  86         my $check = shift @sorted;
  87         unless ($check->[0][1] == 4 and @{$check->[1]} == $parts) {
  88           push @keep, $check;
  89         }
  90       }
  91       unshift @sorted, @keep;
  92     }
  93     push @compacted, $s->[1];
  94   }
  95   return \@compacted;
  96 }
  97
  98 sub rspace {
  99   require DX::ResolutionSpace;
 100   DX::ResolutionSpace->new(@_);
 101 }
 102
 103 sub rstrat {
 104   require DX::ResolutionStrategy;
 105   DX::ResolutionStrategy->new(@_);
 106 }
 107
 108 sub res {
 109   require DX::Resolution;
 110   DX::Resolution->new(@_);
 111 }
 112
 113 sub string {
 114   require DX::Value::String;
 115   DX::Value::String->new(string_value => $_[0])
 116 }
 117
 118 sub number {
 119   require DX::Value::Number;
 120   DX::Value::Number->new(number_value => $_[0]);
 121 }
 122
 123 sub dict {
 124   require DX::Value::Dict;
 125   DX::Value::Dict->new(
 126     members => { @_ },
 127   );
 128 }
 129
 130 sub proposition {
 131   my ($pred, @args) = @_;
 132   require DX::Proposition;
 133   DX::Proposition->new(
 134     predicate => $pred,
 135     args => \@args,
 136   );
 137 }
 138
 139 {
 140   my $dp;
 141
 142   sub deparse {
 143     $dp ||= do {
 144       require DX::TraceFormatter;
 145       DX::TraceFormatter->new;
 146     };
 147     my ($thing) = @_;
 148     $dp->format($thing);
 149   }
 150 }
 151
 152 1;