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