lib/DX/Utils.pm

   1 package DX::Utils;
   2
   3 use strictures 2;
   4 use Exporter 'import';
   5
   6 my @const = (
   7   my @dep_types = qw(EXISTENCE_OF INDICES_OF TYPE_OF CONTENTS_OF),
   8   my @ev_types = qw(VALUE_SET VALUE_EXISTS),
   9 );
  10
  11 our @EXPORT_OK = (
  12   @const,
  13   (my @builders = qw(step string number dict proposition)),
  14   'deparse', 'trace',
  15 );
  16
  17 our %EXPORT_TAGS = (
  18   all => \@EXPORT_OK,
  19   dep_types => \@dep_types,
  20   event_types => \@ev_types,
  21   builders => \@builders,
  22 );
  23
  24 require constant;
  25
  26 # use constant INDICES_OF => \*INDICES_OF;
  27
  28 constant->import(+{
  29   map {; no strict 'refs'; $_ => \*$_ } @const
  30 });
  31
  32 # $INDICES_OF = 1, ...
  33
  34 do { no strict 'refs'; ${$dep_types[$_-1]} = $_ } for 1..@dep_types;
  35
  36 # VALUE_EXISTS needs to trigger indices checks on its parent
  37
  38 our $VALUE_EXISTS = 1;
  39
  40 # VALUE_EXISTS triggers all types, VALUE_SET all but EXISTENCE_OF
  41
  42 our @VALUE_EXISTS = (EXISTENCE_OF(), INDICES_OF(), TYPE_OF(), CONTENTS_OF());
  43 our @VALUE_SET = (INDICES_OF(), TYPE_OF(), CONTENTS_OF());
  44
  45 sub trace {
  46   my ($tag, $thing) = @_;
  47   my $dp = deparse($thing);
  48   $dp =~ s/\n//;
  49   warn "${tag}: ${dp}\n";
  50 }
  51
  52 sub step {
  53   require DX::Step::Normal;
  54   DX::Step::Normal->new(@_);
  55 }
  56
  57 sub string {
  58   require DX::Value::String;
  59   DX::Value::String->new(string_value => $_[0])
  60 }
  61
  62 sub number {
  63   require DX::Value::Number;
  64   DX::Value::Number->new(number_value => $_[0]);
  65 }
  66
  67 sub dict {
  68   require DX::Value::Dict;
  69   DX::Value::Dict->new(
  70     members => { @_ },
  71   );
  72 }
  73
  74 sub proposition {
  75   my ($pred, @args) = @_;
  76   require DX::Proposition;
  77   DX::Proposition->new(
  78     predicate => $pred,
  79     args => \@args,
  80   );
  81 }
  82
  83 {
  84   my $dp;
  85
  86   sub deparse {
  87     $dp ||= do {
  88       require DX::Deparse;
  89       DX::Deparse->new;
  90     };
  91     my ($thing) = @_;
  92     $dp->fmt($thing);
  93   }
  94 }
  95
  96 1;