1. # for our tantrums
2. my class X::Comp::NYI { ... };
3. my class X::Comp::Trait::Unknown { ... };
4. my class X::Comp::Trait::NotOnNative { ... };
5. my class X::Comp::Trait::Scope { ... };
7. # Variable traits come here, not in traits.pm6, since we declare Variable
8. # in the setting rather than BOOTSTRAP.
10. my class Variable {
11. has str $.name;
12. has str $.scope;
13. has $.var is rw;
14. has $.block;
15. has $.slash;
17. # make throwing easier
18. submethod throw ( |c ) {
19. $*W.throw( self.slash, |c );
20. }
22. submethod willdo(&block, $caller-levels = 3) {
23. $caller-levels == 3
24. ?? -> { block(nqp::atkey(nqp::ctxcaller(nqp::ctxcaller(nqp::ctxcaller(nqp::ctx()))), self.name)) }
25. !! -> { block(nqp::atkey(nqp::ctxcaller(nqp::ctx()), self.name)) }
26. }
28. submethod native(Mu $what) {
29. my $name := $what.perl;
30. $name.starts-with('array') || $name eq 'Mu'
31. ?? $name
32. !! $name.ends-with('LexRef')
33. ?? $name.substr(0,3).lc
34. !! '';
35. }
36. }
38. # "is" traits
39. multi sub trait_mod:<is>(Variable:D $v, |c ) {
40. $v.throw( 'X::Comp::Trait::Unknown',
41. type => 'is',
42. subtype => c.hash.keys[0],
43. declaring => ' variable',
44. expected => <TypeObject default dynamic>,
45. );
46. }
47. multi sub trait_mod:<is>(Variable:D $v, Mu :$default!) {
48. my $var := $v.var;
49. my $what := $var.VAR.WHAT;
51. my $descriptor;
52. {
53. $descriptor := nqp::getattr($var, $what.^mixin_base, '$!descriptor');
54. CATCH {
55. my $native = $v.native($what);
56. $native
57. ?? nqp::istype($default,Whatever)
58. ?? $v.throw('X::Comp::NYI',
59. :feature("is default(*) on native $native"))
60. !! $v.throw( 'X::Comp::Trait::NotOnNative',
61. :type<is>, :subtype<default>,
62. :native($native eq 'Mu' ?? ''!! $native )) # yuck
63. !! $v.throw('X::Comp::NYI',
64. :feature("is default on shaped $what.perl()"))
65. }
66. }
68. my $of := $descriptor.of;
69. $v.throw( 'X::Parameter::Default::TypeCheck',
70. :expected($var.WHAT), :got($default =:= Nil ?? 'Nil' !! $default) )
71. unless nqp::istype($default, $of) or $default =:= Nil or $of =:= Mu;
72. $descriptor.set_default(nqp::decont($default));
74. # make sure we start with the default if a scalar
75. $var = $default if nqp::istype($what, Scalar);
76. }
77. multi sub trait_mod:<is>(Variable:D $v, :$dynamic!) {
78. my $var := $v.var;
79. my $what := $var.VAR.WHAT;
80. {
81. nqp::getattr($var,$what.^mixin_base,'$!descriptor').set_dynamic($dynamic);
82. CATCH {
83. my $native = $v.native($what);
84. $native
85. ?? $v.throw( 'X::Comp::Trait::NotOnNative',
86. :type<is>, :subtype<dynamic>,
87. :native($native eq 'Mu' ?? ''!! $native )) # yuck
88. !! $v.throw('X::Comp::NYI',
89. :feature("is dynamic on shaped $what.perl()"))
90. }
91. }
92. }
93. multi sub trait_mod:<is>(Variable:D $v, :$export!) {
94. if $v.scope ne 'our' {
95. $v.throw( 'X::Comp::Trait::Scope',
96. type => 'is',
97. subtype => 'export',
98. declaring => 'variable',
99. scope => $v.scope,
100. supported => ['our'],
101. );
102. }
103. my $var := $v.var;
104. my @tags = flat 'ALL', (nqp::istype($export,Pair) ?? $export.key() !!
105. nqp::istype($export,Positional) ?? @($export)>>.key !!
106. 'DEFAULT');
107. Rakudo::Internals.EXPORT_SYMBOL($var.VAR.name, @tags, $var);
108. }
110. # does trait
111. multi sub trait_mod:<does>(Variable:D $v, Mu:U $role) {
112. if $role.HOW.archetypes.composable() {
113. $v.var.VAR does $role;
114. }
115. elsif $role.HOW.archetypes.composalizable() {
116. $v.var.VAR does $role.HOW.composalize($role);
117. }
118. else {
119. X::Composition::NotComposable.new(
120. target-name => 'a variable',
121. composer => $role,
122. ).throw;
123. }
124. }
126. # phaser traits
127. multi sub trait_mod:<will>(Variable:D $v, $block, |c ) {
128. $v.throw( 'X::Comp::Trait::Unknown',
129. type => 'will',
130. subtype => c.hash.keys[0],
131. declaring => ' variable',
132. expected => ('begin check final init end',
133. 'enter leave keep undo',
134. 'first next last pre post',
135. 'compose'),
136. );
137. }
138. multi sub trait_mod:<will>(Variable:D $v, $block, :$begin! ) {
139. $block($v.var); # no need to delay execution
140. }
141. multi sub trait_mod:<will>(Variable:D $v, $block, :$check! ) {
142. $*W.add_phaser($v.slash, 'CHECK', $block);
143. }
144. multi sub trait_mod:<will>(Variable:D $v, $block, :$final! ) {
145. $v.throw( 'X::Comp::NYI',
146. feature => "Variable trait 'will final {...}'",
147. );
148. }
149. multi sub trait_mod:<will>(Variable:D $v, $block, :$init! ) {
150. $v.throw( 'X::Comp::NYI',
151. feature => "Variable trait 'will init {...}'",
152. );
153. }
154. multi sub trait_mod:<will>(Variable:D $v, $block, :$end! ) {
155. $*W.add_object($block);
156. $*W.add_phaser($v.slash, 'END', $block);
157. }
158. multi sub trait_mod:<will>(Variable:D $v, $block, :$enter! ) {
159. $v.block.add_phaser('ENTER', $v.willdo($block, 1) );
160. }
161. multi sub trait_mod:<will>(Variable:D $v, $block, :$leave! ) {
162. $v.block.add_phaser('LEAVE', $v.willdo($block) );
163. }
164. multi sub trait_mod:<will>(Variable:D $v, $block, :$keep! ) {
165. $v.block.add_phaser('KEEP', $v.willdo($block));
166. }
167. multi sub trait_mod:<will>(Variable:D $v, $block, :$undo! ) {
168. $v.block.add_phaser('UNDO', $v.willdo($block));
169. }
170. multi sub trait_mod:<will>(Variable:D $v, $block, :$first! ) {
171. $v.block.add_phaser('FIRST', $v.willdo($block, 1));
172. }
173. multi sub trait_mod:<will>(Variable:D $v, $block, :$next! ) {
174. $v.block.add_phaser('NEXT', $block);
175. }
176. multi sub trait_mod:<will>(Variable:D $v, $block, :$last! ) {
177. $v.block.add_phaser('LAST', $block);
178. }
179. multi sub trait_mod:<will>(Variable:D $v, $block, :$pre! ) {
180. $v.block.add_phaser('PRE', $v.willdo($block, 1));
181. }
182. multi sub trait_mod:<will>(Variable:D $v, $block, :$post! ) {
183. $v.throw( 'X::Comp::NYI',
184. feature => "Variable trait 'will post {...}'",
185. );
186. }
187. multi sub trait_mod:<will>(Variable:D $v, $block, :$compose! ) {
188. $v.throw( 'X::Comp::NYI',
189. feature => "Variable trait 'will compose {...}'",
190. );
191. }