Commit | Line | Data |
88eac4d2 |
1 | package DX::Expander; |
2 | |
3 | use DX::Utils qw(:all); |
4 | use DX::Value::True; |
5 | use DX::Value::False; |
cfae7810 |
6 | use Types::Standard qw(InstanceOf); |
88eac4d2 |
7 | use Tcl; |
8 | use DX::Class; |
9 | |
10 | has tcl => ( |
cfae7810 |
11 | is => 'lazy', builder => sub { Tcl->new }, isa => InstanceOf['Tcl'], |
88eac4d2 |
12 | handles => { _split_list => 'SplitList' }, |
13 | ); |
14 | |
15 | sub expand_args { |
16 | my ($self, @args) = @_; |
17 | map { $self->expand_one($_) } @args; |
18 | } |
19 | |
20 | sub expand_proposition { |
21 | my ($self, $prop) = @_; |
22 | my ($name, @args) = $self->_split_list($prop); |
23 | proposition($name, $self->expand_args(@args)); |
24 | } |
25 | |
26 | my @exp_t = map { [ qr/\A(\s*)${\$_->[1]}\s*\Z/, 'expand_'.$_->[0] ] } ( |
27 | [ number => qr/([\d.]+)/ ], |
28 | [ string => qr/'(.*)'/s ], |
29 | [ bool => qr/(true|false)/ ], |
d1b6cb33 |
30 | # foo or Foo or ?Foo or _Foo or ?_Foo |
31 | [ symbol => qr/((?:[a-z]|\??[A-Z_])[a-zA-Z0-9_]*)/ ], |
88eac4d2 |
32 | [ dict => qr/{(.*)}/s ], |
33 | [ array => qr/\[(.*)\]/s ], |
34 | ); |
35 | |
36 | sub expand_one { |
37 | my ($self, $exp) = @_; |
38 | foreach my $try (@exp_t) { |
39 | my ($re, $meth) = @$try; |
40 | $exp =~ $re and return $self->$meth($2, $1); |
41 | } |
42 | die 'Uhhhh ... '.$exp; |
43 | } |
44 | |
45 | sub expand_number { number($_[1]) } |
46 | |
47 | sub expand_string { |
48 | my ($self, $exp, $ws) = @_; |
49 | return string($exp) unless $ws =~ s/.*\n//s; |
50 | my $wstrip = length($ws)+1; |
51 | $exp =~ s/^ {1,$wstrip}//mg; |
52 | return string($exp); |
53 | } |
54 | |
55 | sub expand_symbol { $_[1] } |
56 | |
57 | sub expand_dict { |
58 | my ($self, $val) = @_; |
59 | my @pairs = $self->_split_list($val); |
60 | die "Uneven dict" if @pairs % 2; |
61 | dict(map { |
62 | $pairs[2*$_] => $self->expand_one($pairs[(2*$_)+1]) |
63 | } 0..int($#pairs/2)) |
64 | } |
65 | |
66 | sub expand_array { die; |
67 | } |
68 | |
69 | sub expand_bool { |
70 | ('DX::Value::'.ucfirst($_[1]))->new |
71 | } |
72 | |
73 | 1; |