1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
#!perl
use warnings FATAL => 'all';
use strict;
use Test::More tests => 12;
{
package MyTC;
use overload
'|' => 'union',
'&{}' => 'apply',
fallback => 1;
sub new {
my ($class, $name) = @_;
bless { _name => $name }, $class
}
sub name { $_[0]{_name} }
sub check { 1 }
sub get_message { die "Internal error: get_message: ${\$_[0]->name}"; }
sub union {
my ($x, $y) = @_;
ref($x)->new($x->name . '|' . $y->name)
}
sub apply {
my $self = shift;
sub {
return $self if !@_;
@_ == 1 or die "Internal error: apply->(@_)";
my @args = @{$_[0]};
ref($self)->new($self->name . '[' . join(',', map $_->name, @args) . ']')
}
}
}
use Function::Parameters;
BEGIN {
for my $suffix ('a' .. 't') {
my $name = "T$suffix";
my $obj = MyTC->new($name);
my $symbol = do { no strict 'refs'; \*$name };
*$symbol = sub { $obj->(@_) };
}
}
is eval 'fun (NoSuchType $x) {}', undef;
like $@, qr/\AUndefined type name main::NoSuchType /;
is eval 'fun (("NoSuchType") $x) {}', undef;
like $@, qr/\AUndefined type name main::NoSuchType /;
for my $f (
fun ( Ta[Tb] | Td | Tf [ Tg, Ti, Tj | Tk[Tl], To [ Tq, Tr ] | Tt ] $x) {},
fun ((' Ta[Tb] | Td | Tf [ Tg, Ti, Tj | Tk[Tl], To [ Tq, Tr ] | Tt ] ') $x) {},
) {
my $m = Function::Parameters::info $f;
is my ($xi) = $m->positional_required, 1;
is $xi->name, '$x';
my $t = $xi->type;
is ref $t, 'MyTC';
is $t->name, 'Ta[Tb]|Td|Tf[Tg,Ti,Tj|Tk[Tl],To[Tq,Tr]|Tt]';
}
|
