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
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
#!/usr/bin/perl
use v5.26;
use warnings;
use Test2::V0;
use Tangence::Compiler::Parser;
use Tangence::Constants;
use lib ".";
my $parser = Tangence::Compiler::Parser->new;
{
my $meta = $parser->from_file( "t/Ball.tan" );
is( [ sort keys %$meta ], [sort qw( t.Colourable t.Ball )], 'keys of t/Ball.tan' );
my $methods;
my $events;
my $props;
my @args;
my $colourable = $meta->{'t.Colourable'};
isa_ok( $colourable, [ "Tangence::Meta::Class" ], 't.Colourable meta' );
is( $colourable->name, "t.Colourable", 't.Colourable name' );
is( $colourable->perlname, "t::Colourable", 't.Colourable perlname' );
$props = $colourable->direct_properties;
is( [ sort keys %$props ], [qw( colour )], 't.Colourable direct props' );
isa_ok( $props->{colour}, [ "Tangence::Meta::Property" ], 't.Colourable prop colour' );
is( $props->{colour}->name, "colour", 't.Colourable prop colour name' );
is( $props->{colour}->dimension, DIM_SCALAR, 't.Colourable prop colour dimension' );
isa_ok( $props->{colour}->type, [ "Tangence::Meta::Type" ], 't.Colourable prop colour type' );
is( $props->{colour}->type->sig, "str", 't.Colourable prop colour type sig' );
ok( !$props->{colour}->smashed, 't.Colourable prop colour !smashed' );
is( [ sort keys %{ $colourable->properties } ], [qw( colour )], 't.Colourable props' );
ref_is( $colourable->property( "colour" ), $props->{colour}, 't.Colourable ->property' );
my $ball = $meta->{'t.Ball'};
isa_ok( $ball, [ "Tangence::Meta::Class" ], 't.Ball meta' );
$methods = $ball->direct_methods;
is( [ sort keys %$methods ], [qw( bounce )], 't.Ball direct methods' );
isa_ok( $methods->{bounce}, [ "Tangence::Meta::Method" ], 't.Ball method bounce' );
ref_is( $methods->{bounce}->class, $ball, 't.Ball method bounce class' );
is( $methods->{bounce}->name, "bounce", 't.Ball method bounce name' );
@args = $methods->{bounce}->arguments;
is( scalar @args, 1, 't.Ball method bounce has 1 argument' );
is( $args[0]->name, "howhigh", 't.Ball method bounce arg[0] name' );
isa_ok( $args[0]->type, [ "Tangence::Meta::Type" ], 't.Ball method bounce arg[0] type' );
is( $args[0]->type->sig, "str", 't.Ball method bounce arg[0] type sig' );
is( [ map $_->sig, $methods->{bounce}->argtypes ], [qw( str )], 't.Ball method bounce argtypes sigs' );
isa_ok( $methods->{bounce}->ret, [ "Tangence::Meta::Type" ], 't.Ball method bounce ret' );
is( $methods->{bounce}->ret->sig, "str", 't.Ball method bounce ret sig' );
is( [ sort keys %{ $ball->methods } ], [qw( bounce )], 't.Ball methods' );
ref_is( $ball->method( "bounce" ), $methods->{bounce}, 't.Ball ->method' );
$events = $ball->direct_events;
is( [ sort keys %$events ], [qw( bounced )], 't.Ball direct events' );
isa_ok( $events->{bounced}, [ "Tangence::Meta::Event" ], 't.Ball event bounced' );
ref_is( $events->{bounced}->class, $ball, 't.Ball event bounced class' );
is( $events->{bounced}->name, "bounced", 't.Ball event bounced name' );
@args = $events->{bounced}->arguments;
is( scalar @args, 1, 't.Ball event bounced has 1 argument' );
is( $args[0]->name, "howhigh", 't.Ball event bounced arg[0] name' );
isa_ok( $args[0]->type, [ "Tangence::Meta::Type" ], 't.Ball event bounced arg[0] type' );
is( $args[0]->type->sig, "str", 't.Ball event bounced arg[0] type sig' );
is( [ map $_->sig, $events->{bounced}->argtypes ], [qw( str )], 't.Ball event bounced argtypes sigs' );
is( [ sort keys %{ $ball->events } ], [qw( bounced )], 't.Ball events' );
ref_is( $ball->event( "bounced" ), $events->{bounced}, 't.Ball ->event' );
$props = $ball->direct_properties;
is( [ sort keys %$props ], [qw( size )], 't.Ball direct props' );
ref_is( $props->{size}->class, $ball, 't.Ball prop size class' );
is( $props->{size}->name, "size", 't.Ball prop size name' );
is( $props->{size}->dimension, DIM_SCALAR, 't.Ball prop size dimension' );
isa_ok( $props->{size}->type, [ "Tangence::Meta::Type" ], 't.Ball prop size type' );
is( $props->{size}->type->sig, "int", 't.Ball prop size type sig' );
ok( $props->{size}->smashed, 't.Ball prop size smashed' );
is( [ sort keys %{ $ball->properties } ], [qw( colour size )], 't.Ball props' );
ref_is( $ball->property( "size" ), $props->{size}, 't.Ball ->property' );
is( [ map { $_->name } $ball->direct_superclasses ], [qw( t.Colourable )], 't.Ball direct superclasses' );
is( [ map { $_->name } $ball->superclasses ], [qw( t.Colourable )], 't.Ball superclasses' );
}
{
my $meta = $parser->from_file( "t/TestObj.tan" );
my $testobj = $meta->{'t.TestObj'};
my $props = $testobj->direct_properties;
is( $props->{array}->dimension, DIM_ARRAY, 't.TestObj prop array dimension' );
is( $props->{array}->type->sig, "int", 't.TestObj prop array type sig' );
is( $props->{hash}->dimension, DIM_HASH, 't.TestObj prop hash dimension' );
is( $props->{hash}->type->sig, "int", 't.TestObj prop hash type sig' );
is( $props->{queue}->dimension, DIM_QUEUE, 't.TestObj prop queue dimension' );
is( $props->{queue}->type->sig, "int", 't.TestObj prop queue type sig' );
is( $props->{scalar}->dimension, DIM_SCALAR, 't.TestObj prop scalar dimension' );
is( $props->{scalar}->type->sig, "int", 't.TestObj prop scalar type' );
is( $props->{objset}->dimension, DIM_OBJSET, 't.TestObj prop objset dimension' );
is( $props->{objset}->type->sig, "obj", 't.TestObj prop objset type' );
is( $props->{items}->dimension, DIM_SCALAR, 't.TestObj prop items dimension' );
is( $props->{items}->type->aggregate, "list", 't.TestObj prop items type' );
is( $props->{items}->type->sig, "list(obj)", 't.TestObj prop items type sig' );
my $teststruct = $meta->{"t.TestStruct"};
my @fields = $teststruct->fields;
is( $fields[0]->name, "b", 't.TestStruct field b' );
is( $fields[0]->type->sig, "bool", 't.TestStruct field b type sig' );
is( $fields[1]->name, "i", 't.TestStruct field i' );
is( $fields[1]->type->sig, "int", 't.TestStruct field i type sig' );
is( $fields[2]->name, "f", 't.TestStruct field f' );
is( $fields[2]->type->sig, "float", 't.TestStruct field f type sig' );
is( $fields[3]->name, "s", 't.TestStruct field s' );
is( $fields[3]->type->sig, "str", 't.TestStruct field s type sig' );
is( $fields[4]->name, "o", 't.TestStruct field o' );
is( $fields[4]->type->sig, "obj", 't.TestStruct field o type sig' );
}
done_testing;
|
