lib/DX/Deparse.pm

   1 package DX::Deparse;
   2
   3 use DX::Class;
   4
   5 sub indent_by { '    ' }
   6
   7 sub max_width { 78 }
   8
   9 sub _inner_meta {
  10   my ($self, $ometa) = @_;
  11   +{ %$ometa, width_left => $ometa->{width_left} - length $self->indent_by };
  12 }
  13
  14 sub _indent_one {
  15   my ($self, $to_indent) = @_;
  16   $to_indent =~ s/^/${\$self->indent_by}/mg;
  17   $to_indent;
  18 }
  19
  20 sub fmt {
  21   my ($self, $thing) = @_;
  22   $self->_fmt($thing, { width_left => $self->max_width })."\n";
  23 }
  24
  25 sub _fmt {
  26   my ($self, $thing, $meta) = @_;
  27   return '{}' unless defined($thing);
  28   return $thing unless ref($thing);
  29   my $type = join'_', split '::', lc +(ref($thing) =~ /^(?:DX::)?(.*)/)[0];
  30   $self->${\"_fmt_${type}"}($thing, $meta);
  31 }
  32
  33 sub _fmt_value_dict {
  34   my ($self, $dict, $meta) = @_;
  35   my $chunks = $self->_fmt_pairs([
  36     map [ $_, $dict->get_member_at($_) ], $dict->index_list
  37   ], $meta);
  38   return '{{ }}' unless $chunks =~ /\S/;
  39   s/^\s+//, s/\n\s+/ /g for (my $maybe = $chunks);
  40   return "{{ ${maybe} }}" if length($maybe) < $meta->{width_left};
  41   "{{\n${chunks}\n}}";
  42 }
  43
  44 sub _fmt_pairs {
  45   my ($self, $pairs, $ometa) = @_;
  46   my $imeta = $self->_inner_meta($ometa);
  47   $self->_indent_one(join "\n", map {
  48     join ' ', map $self->_fmt($_, $imeta), @$_
  49   } @$pairs);
  50 }
  51
  52 sub _fmt_value_string {
  53   my ($self, $string) = @_;
  54   # TODO: multiline handling
  55   my $val = $string->string_value;
  56   if ($val =~ /^\w+$/) {
  57     qq{'${val}'}
  58   } else {
  59     qq{{'${val}'}}
  60   }
  61 }
  62
  63 sub _fmt_value_number { $_[1]->number_value }
  64
  65 sub _fmt_value_true { 'true' }
  66
  67 sub _fmt_value_false { 'false' }
  68
  69 sub _fmt_value_unset { 'unset' }
  70
  71 sub _fmt_object {
  72   my ($self, $pairs, $meta) = @_;
  73   my $chunks = $self->_fmt_pairs($pairs, $meta);
  74   return '{ }' unless $chunks =~ /\S/;
  75   s/^\s+//, s/\n\s+/ /g for (my $maybe = $chunks);
  76   return "{ ${maybe} }" if length($maybe) < $meta->{width_left};
  77   "{\n${chunks}\n}"
  78 }
  79
  80 sub _fmt_hypothesis {
  81   my ($self, $hyp, $meta) = @_;
  82   $self->_fmt_object([
  83     map [ $_ => $hyp->$_ ],
  84       qw(actions resolved_propositions scope)
  85   ], $meta);
  86 }
  87
  88 sub _fmt_array {
  89   my ($self, $ary, $ometa) = @_;
  90   my $imeta = $self->_inner_meta($ometa);
  91   my $chunks = $self->_indent_one(
  92     join "\n", map $self->_fmt($_, $imeta), @$ary
  93   );
  94   return '{ }' unless $chunks =~ /\S/;
  95   "{\n${chunks}\n}";
  96 }
  97
  98 sub _fmt_glob {
  99   my ($self, $glob, $meta) = @_;
 100   return ((''.*$glob) =~ /::([A-Z_]+)$/)[0];
 101 }
 102
 103 sub _fmt_action_setvalue {
 104   my ($self, $action, $meta) = @_;
 105   $self->_fmt_action_generic(SetValue => $action, $meta);
 106 }
 107
 108 sub _fmt_action_addvalue {
 109   my ($self, $action, $meta) = @_;
 110   $self->_fmt_action_generic(AddValue => $action, $meta);
 111 }
 112
 113 sub _fmt_action_bindvalue {
 114   my ($self, $action, $meta) = @_;
 115   my $path = join '.', map $self->_fmt($_, $meta), @{$action->target_path};
 116   my $bound_path = join '.',
 117                      map $self->_fmt($_, $meta),
 118                        @{$action->new_value
 119                                 ->action_builder
 120                                 ->inner_action_builder
 121                                 ->target_path};
 122   join ' ', BindValue => $path, $bound_path;
 123 }
 124
 125 sub _fmt_action_addboundvalue {
 126   my ($self, $action, $meta) = @_;
 127   $self->_fmt_action_generic(AddBoundValue => $action, $meta);
 128 }
 129
 130 sub _fmt_action_setboundvalue {
 131   my ($self, $action, $meta) = @_;
 132   $self->_fmt_action_generic(SetBoundValue => $action, $meta);
 133 }
 134
 135 sub _fmt_action_generic {
 136   my ($self, $name, $action, $meta) = @_;
 137   my $path = join '.', map $self->_fmt($_, $meta), @{$action->target_path};
 138   join ' ', $name, $path, $self->_fmt($action->new_value, $meta);
 139 }
 140
 141 sub _fmt_resolvedpropositionset {
 142   my ($self, $rps, $meta) = @_;
 143   $self->_fmt_object([
 144     map {
 145       [ $_, [
 146         map bless([ @$_ ], 'DX::Dependency'),
 147           map @{$_}[1..$#$_],
 148             @{$rps->dependencies_for($_)}
 149       ] ]
 150     } @{$rps->propositions},
 151   ], $meta);
 152 }
 153
 154 sub _fmt_dependency {
 155   my ($self, $dep, $meta) = @_;
 156   '{ '.join(' ', map $self->_fmt($_, $meta), @$dep).' }'
 157 }
 158
 159 sub _fmt_proposition {
 160   my ($self, $prop, $meta) = @_;
 161   join ' ',
 162     $prop->predicate,
 163     map $self->_fmt($_, $meta),
 164       map +((!ref($_) and $prop->introduced_names->{$_}) ? "?$_" : $_),
 165         @{$prop->args};
 166 }
 167
 168 sub _fmt_scope {
 169   my ($self, $scope, $meta) = @_;
 170   $self->_fmt_object([
 171     [ W => $scope->globals ],
 172     map [ $_ => $scope->locals->[$_] ], 0..$#{$scope->locals}
 173   ], $meta);
 174 }
 175
 176 sub _fmt_searchstate {
 177   my ($self, $ss, $meta) = @_;
 178   $self->_fmt_object([
 179     [ adjustments_made => '{...}' ],
 180     [ current_hypothesis => $ss->current_hypothesis ],
 181   ], $meta);
 182 }
 183
 184 sub _fmt_step_considerproposition {
 185   my ($self, $step, $meta) = @_;
 186   'consider '.$self->_fmt($step->proposition, $meta);
 187 }
 188
 189 sub _fmt_step_resolveproposition {
 190   my ($self, $step, $meta) = @_;
 191   'resolve '.$self->_fmt_object([
 192     [ actions => $step->actions ],
 193     ($step->alternative_step
 194       ? [ alternative_step => '...' ]
 195       : ()),
 196     [ depends_on => [
 197       map bless([ @$_ ], 'DX::Dependency'),
 198         map @{$_}[1..$#$_],
 199           @{$step->depends_on}
 200     ] ],
 201   ], $meta);
 202 }
 203
 204 sub _fmt_step_backtrack { 'backtrack' }
 205
 206 sub _fmt_step_markassolution { 'mark as solution' }
 207
 208 sub _fmt_step_enterrecheck {
 209   my ($self, $step, $meta) = @_;
 210   'recheck '.$self->_fmt($step->proposition_list->[0], $meta);
 211 }
 212
 213 sub _fmt_step_completerecheck { 'complete recheck' }
 214
 215 sub _fmt_step_failrecheck { 'fail recheck' }
 216
 217 1;