updated shell code to register query commands with Tcl object

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

package DX::Expander;

use DX::Utils qw(:all);
use DX::Value::True;
use DX::Value::False;
use Tcl;
use DX::Class;

has tcl => (
  is => 'lazy', builder => sub { Tcl->new },
  handles => { _split_list => 'SplitList' },
);

sub expand_args {
  my ($self, @args) = @_;
  map { $self->expand_one($_) } @args;
}

sub expand_proposition {
  my ($self, $prop) = @_;
  my ($name, @args) = $self->_split_list($prop);
  proposition($name, $self->expand_args(@args));
}

my @exp_t = map { [ qr/\A(\s*)${\$_->[1]}\s*\Z/, 'expand_'.$_->[0] ] } (
  [ number => qr/([\d.]+)/ ],
  [ string => qr/'(.*)'/s ],
  [ bool => qr/(true|false)/ ],
  [ symbol => qr/([a-zA-Z_][a-zA-Z0-9_]*)/ ],
  [ dict => qr/{(.*)}/s ],
  [ array => qr/\[(.*)\]/s ],
);

sub expand_one {
  my ($self, $exp) = @_;
  foreach my $try (@exp_t) {
    my ($re, $meth) = @$try;
    $exp =~ $re and return $self->$meth($2, $1);
  }
  die 'Uhhhh ... '.$exp;
}

sub expand_number { number($_[1]) }

sub expand_string {
  my ($self, $exp, $ws) = @_;
  return string($exp) unless $ws =~ s/.*\n//s;
  my $wstrip = length($ws)+1;
  $exp =~ s/^ {1,$wstrip}//mg;
  return string($exp);
}

sub expand_symbol { $_[1] }

sub expand_dict {
  my ($self, $val) = @_;
  my @pairs = $self->_split_list($val);
  die "Uneven dict" if @pairs % 2;
  dict(map {
    $pairs[2*$_] => $self->expand_one($pairs[(2*$_)+1])
  } 0..int($#pairs/2))
}

sub expand_array { die;
}

sub expand_bool {
  ('DX::Value::'.ucfirst($_[1]))->new
}

1;