-
Notifications
You must be signed in to change notification settings - Fork 135
/
composition.t
229 lines (195 loc) · 6.53 KB
/
composition.t
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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
use v6;
use Test;
plan 49;
# L<S14/Roles/"Roles may be composed into a class at compile time">
role rA {
method mA1 {
'mA1';
}
method mA2 {
'mA2';
}
};
role rB {
method mB1 {
'mB1';
}
method mB2 {
'mB2';
}
};
class C1 does rA {
method mC1 {
'mC1';
}
};
my $x = C1.new();
is $x.mC1, 'mC1', 'Can call method of class with mixed in role';
is $x.mA1, 'mA1', 'Call first method from role';
is $x.mA2, 'mA2', 'Call second method from role';
class C2 does rA does rB {
method mC2 {
'mC2';
}
}
my $y = C2.new();
is $y.mC2, 'mC2', 'Can call method of class with two roles mixed in';
is $y.mA1, 'mA1', 'Can call mixed in method (two roles) 1';
is $y.mA2, 'mA2', 'Can call mixed in method (two roles) 2';
is $y.mB1, 'mB1', 'Can call mixed in method (two roles) 3';
is $y.mB2, 'mB2', 'Can call mixed in method (two roles) 4';
ok C2 ~~ rA, 'class matches first role';
ok C2 ~~ rB, 'class matches second role';
ok rA !~~ C2, 'first role does not match class';
ok rB !~~ C2, 'second role does not match class';
role RT64002 does rA does rB {}
ok RT64002 ~~ rA, 'role matches first role it does';
ok RT64002 ~~ rB, 'role matches second role it does';
ok rA !~~ RT64002, 'role not matched by first role it does';
ok rB !~~ RT64002, 'role not matched by second role it does';
{
class D1 does rA {
method mA1 {
'D1.mA1';
}
}
my $z = D1.new();
is $z.mA1, 'D1.mA1', 'Can override method in a role with method in a class';
}
# diamond composition
#?rakudo skip 'diamond composition RT #124749'
{
role DA {
method foo { "OH HAI" };
}
role DB does DA { }
role DC does DA { }
class DD does DB does DC { };
is DD.new.foo, 'OH HAI', 'diamond role composition';
class DE is DB is DC { };
is DE.new.foo, 'OH HAI', 'same with punning and inheritance';
}
# RT #69919
{
role RT69919 {
my $lex = 'Luthor';
method rt69919 { return $lex }
}
class IL does RT69919 {}
is IL.new.rt69919, 'Luthor', 'access lexical declared in role from method called via class that does the role';
}
# inheritance through role composition - specced in A12
# RT #69254
{
class irA {};
role irB is irA {};
class irC does irB {};
ok irC ~~ irB, 'role composition worked';
ok irC ~~ irA, 'role composition transported inheritance';
}
# RT #72856
{
role RT72856A { method foo {} };
role RT72856B { method foo {} };
try { EVAL 'class RT72856C does RT72856A does RT72856B {}' };
ok $! ~~ /foo/,
'method of the same name from two different roles collide in a class composition';
ok $! ~~ /RT72856A/, 'colliding role mentioned in error (1)';
ok $! ~~ /RT72856B/, 'colliding role mentioned in error (2)';
}
# RT #74078
{
role UsesSettingSub {
method doit() {
uc 'a';
}
}
class ClassUsesSettingSub does UsesSettingSub { };
is ClassUsesSettingSub.new.doit, 'A',
'can use a sub from the setting in a method composed from a role';
}
# RT #64766
{
my class A {
method foo { "OH HAI" }
method aie { "AIE!" }
}
{
my role B { has A $.bar handles 'aie' }
my class C does B { }
is C.new.aie, 'AIE!', 'literal handles from role is composed (1)';
throws-like { C.new.foo }, X::Method::NotFound,
'literal handles from role is composed (2)';
}
{
my role B { has A $.bar handles * }
my class C does B { }
is C.new.foo, 'OH HAI', 'wildcard handles from role is composed (1)';
is C.new.aie, 'AIE!', 'wildcard handles from role is composed (2)';
}
eval-dies-ok q:to/END/, 'attributes conflict in role composition';
my role B {
has A $.bar handles "aie"
}
my class C does B {
has A $.bar handles "foo"
}
END
}
# RT #124393
{
my role R1 {
multi method m(Int $x) { ... }
multi method m(Str $x) { ... }
}
my class C1 does R1 {
multi method m(Int $x) { 42 }
multi method m(Str $x) { 'the answer' }
}
is C1.m(1), 42, 'stubbed multi in role implemented in class can be called (1)';
is C1.m('x'), 'the answer', 'stubbed multi in role implemented in class can be called (2)';
my $msg;
dies-ok { EVAL 'my class C2 does R1 { }'; CATCH { $msg = .message } },
'must implement stubbed multi methods in roles (1)';
ok $msg ~~ /required/, 'must implement stubbed multi methods in roles (2)';
my role R2 {
multi method m(Int $x) { 99 }
multi method m(Str $x) { 'ice cream' }
}
my class C3 does R1 does R2 {
}
is C3.m(1), 99, 'another role can provided required multi implementation (1)';
is C3.m('x'), 'ice cream', 'another role can provided required multi implementation (2)';
my class C4 does R1 does R2 {
multi method m(Int $x) { 69 }
}
is C4.m(1), 69, 'class can override multi method from role';
is C4.m('x'), 'ice cream', 'other multi candidates from role survive';
my role R3 {
multi method m(Int $x) { 101 }
multi method m(Str $x) { 'dalmatians' }
}
dies-ok { EVAL 'my class C5 does R2 does R3 { }'; CATCH { $msg = .message } },
'multis with same sig are composition conflicts (1)';
ok $msg ~~ /'multiple roles'/, 'multis with same sig are composition conflicts (2)';
my class C6 does R2 does R3 {
multi method m(Int $x) { 11 }
multi method m(Str $x) { 'pipers' }
}
is C6.m(1), 11, 'class can resolve conflicts from multis by implementing method (1)';
is C6.m(1), 11, 'class can resolve conflicts from multis by implementing method (2)';
my role R4 does R1 { }
dies-ok { EVAL 'my class C7 does R4 { }'; CATCH { $msg = .message } },
'stubbed method from role brought in by role must be satisfied (1)';
ok $msg ~~ /required/, 'stubbed method from role brought in by role must be satisfied (2)';
my class C8 does R4 {
multi method m(Int $x) { 40 }
multi method m(Str $x) { 'days' }
}
is C8.m(1), 40, 'class can satisfy stub from role brought in by role (1)';
is C8.m('x'), 'days', 'class can satisfy stub from role brought in by role (2)';
my class C9 does R4 does R2 { }
is C9.m(1), 99, 'another role can provided indirectly required multi implementation (1)';
is C9.m('x'), 'ice cream', 'another role can provided indirectly required multi implementation (2)';
}
# vim: syn=perl6