Singleton implementation on perl6 - raku

I looked at the following code on Rosetta code http://rosettacode.org/wiki/Singleton#Perl_6
which implements Singleton in Perl6
class Singleton {
has Int $.x is rw;
# We create a lexical variable in the class block that holds our single instance.
my Singleton $instance = Singleton.bless; # You can add initialization arguments here.
method new {!!!} # Singleton.new dies.
method instance { $instance; }
}
my $a=Singleton.bless(x => 1);
my $b=Singleton.bless(x=> 2);
say $a.x;
say $b.x;
#result
# 1
# 2
but it seems using this implementation i can create tow instances of the same class using bless see example above ,
is there an option to prevent the implemention to only one instance of the same class ?

Perl prides itself on providing many ways to do things leaving you to pick the one that suits your tastes and the application at hand. I say that to highlight that this is one simple but solid, hopefully self-explanatory way - I'm not putting it forward as "the best" because that depends on your circumstances.
#!/usr/bin/env perl6
class Scoreboard {
has Str $.home-team ;
has Str $.away-team ;
has Int $.home-score = 0 ;
has Int $.away-score = 0 ;
my Scoreboard $instance;
method new(*%named) {
return $instance //= self.bless(|%named) ;
}
multi method goal($team where * eq $!home-team, Int :$points = 6) {
$!home-score += $points
}
multi method goal($team where * eq $!away-team, Int :$points = 6) {
$!away-score += $points
}
method Str {
"At this vital stage of the game " ~
do given $!home-score <=> $!away-score {
when More {
"$!home-team are leading $!away-team, $!home-score points to $!away-score"
}
when Less {
"$!home-team are behind $!away-team, $!home-score points to $!away-score"
}
default {
"the scores are level! $!home-score apeice!"
}
}
}
}
my $home-team = "The Rabid Rabbits";
my $away-team = "The Turquoise Turtles"; # Go them turtles!
my $scoreboard = Scoreboard.new( :$home-team , :$away-team );
$scoreboard.goal($home-team, :4points) ;
say "$scoreboard";
$scoreboard.goal($away-team) ;
say "$scoreboard";
my $evil_second_scoreboard = Scoreboard.new;
$evil_second_scoreboard.goal($home-team, :2points) ;
say "$evil_second_scoreboard";
This produces;
At this vital stage of the game The Rabid Rabbits are leading The Turquoise Turtles, 4 points to 0
At this vital stage of the game The Rabid Rabbits are behind The Turquoise Turtles, 4 points to 6
At this vital stage of the game the scores are level! 6 apeice!
This overrides the default new (normally supplied by class Mu) and keep a reference to ourself (ie this object) in private class data. For private class data, we use a lexically scoped scalar declared with my. The // is the operator form of .defined. So, on the first run, we call bless which allocates the object and initialize the attributes, and then assign it to $instance. In subsequent calls to new, $instance is defined and is immediately returned.
If you want to prevent someone calling bless directly, you can add;
method bless(|) {
nextsame unless $instance;
fail "bless called on singleton Scoreboard"
}
which will ensure that only the first call will work.

Related

Raku Ambiguous call to infix(Hyper: Dan::Series, Int)

I am writing a model Series class (kinda like the one in pandas) - and it should be both Positional and Associative.
class Series does Positional does Iterable does Associative {
has Array $.data is required;
has Array $.index;
### Construction ###
method TWEAK {
# sort out data-index dependencies
$!index = gather {
my $i = 0;
for |$!data -> $d {
take ( $!index[$i++] => $d )
}
}.Array
}
### Output ###
method Str {
$!index
}
### Role Support ###
# Positional role support
# viz. https://docs.raku.org/type/Positional
method of {
Mu
}
method elems {
$!data.elems
}
method AT-POS( $p ) {
$!data[$p]
}
method EXISTS-POS( $p ) {
0 <= $p < $!data.elems ?? True !! False
}
# Iterable role support
# viz. https://docs.raku.org/type/Iterable
method iterator {
$!data.iterator
}
method flat {
$!data.flat
}
method lazy {
$!data.lazy
}
method hyper {
$!data.hyper
}
# Associative role support
# viz. https://docs.raku.org/type/Associative
method keyof {
Str(Any)
}
method AT-KEY( $k ) {
for |$!index -> $p {
return $p.value if $p.key ~~ $k
}
}
method EXISTS-KEY( $k ) {
for |$!index -> $p {
return True if $p.key ~~ $k
}
}
#`[ solution attempt #1 does NOT get called
multi method infix(Hyper: Series, Int) is default {
die "I was called"
}
#]
}
my $s = Series.new(data => [rand xx 5], index => [<a b c d e>]);
say ~$s;
say $s[2];
say $s<b>;
So far pretty darn cool.
I can go dd $s.hyper and get this
HyperSeq.new(configuration => HyperConfiguration.new(batch => 64, degree => 1))
BUT (there had to be a but coming), I want to be able to do hyper math on my Series' elements, something like:
say $s >>+>> 2;
But that yields:
Ambiguous call to 'infix(Hyper: Dan::Series, Int)'; these signatures all match:
(Hyper: Associative:D \left, \right, *%_)
(Hyper: Positional:D \left, \right, *%_)
in block <unit> at ./synopsis-dan.raku line 63
How can I tell my class Series not to offer the Associative hyper candidate...?
Note: edited example to be a runnable MRE per #raiph's comment ... I have thus left in the minimum requirements for the 3 roles in play per docs.raku.org
After some experimentation (and new directions to consider from the very helpful comments to this SO along the way), I think I have found a solution:
drop the does Associative role from the class declaration like this:
class Series does Positional does Iterable {...}
BUT
leave the Associative role support methods in the body of the class:
# Associative role support
# viz. https://docs.raku.org/type/Associative
method keyof {
Str(Any)
}
method AT-KEY( $k ) {
for |$!index -> $p {
return $p.value if $p.key ~~ $k
}
}
method EXISTS-KEY( $k ) {
for |$!index -> $p {
return True if $p.key ~~ $k
}
}
This gives me the Positional and Associative accessors, and functional hyper math operators:
my $s = Series.new(data => [rand xx 5], index => [<a b c d e>]);
say ~$s; #([a => 0.6137271559776396 b => 0.7942959887386045 c => 0.5768018697817604 d => 0.8964323560788711 e => 0.025740150933493577] , dtype: Num)
say $s[2]; #0.7942959887386045
say $s<b>; #0.5768018697817604
say $s >>+>> 2; #(2.6137271559776396 2.7942959887386047 2.5768018697817605 2.896432356078871 2.0257401509334936)
While this feels a bit thin (and probably lacks the full set of Associative functions) I am fairly confident that the basic methods will give me slimmed down access like a hash from a key capability that I seek. And it no longer creates the ambiguous call.
This solution may be cheating a bit in that I know the level of compromise that I will accept ;-).
Take #1
First, an MRE with an emphasis on the M1:
class foo does Positional does Associative { method of {} }
sub infix:<baz> (\l,\r) { say 'baz' }
foo.new >>baz>> 42;
yields:
Ambiguous call to 'infix(Hyper: foo, Int)'; these signatures all match:
(Hyper: Associative:D \left, \right, *%_)
(Hyper: Positional:D \left, \right, *%_)
in block <unit> at ./synopsis-dan.raku line 63
The error message shows it's A) a call to a method named infix with an invocant matching Hyper, and B) there are two methods that potentially match that call.
Given that there's no class Hyper in your MRE, these methods and the Hyper class must be either built-ins or internal details that are leaking out.
A search of the doc finds no such class. So Hyper is undocumented Given that the doc has fairly broad coverage these days, this suggests Hyper is an internal detail. But regardless, it looks like you can't solve your problem using official/documented features.
Hopefully this bad news is still better than none.2
Take #2
Where's the fun in letting little details like "not an official feature" stop us doing what we want to do?
There's a core.c module named Hyper.pm6 in the Rakudo source repo.
A few seconds browsing that, and clicks on its History and Blame, and I can instantly see it really is time for me to conclude this SO answer, with a recommendation for your next move.
To wit, I suggest you start another SO, using this answer as its heart (but reversing my presentation order, ie starting by mentioning Hyper, and that it's not doc'd), and namechecking Liz (per Hyper's History/Blame), with a link back to your Q here as its background. I'm pretty sure that will get you a good answer, or at least an authoritative one.
Footnotes
1 I also tried this:
class foo does Positional does Associative { method of {} }
sub postfix:<bar>(\arg) { say 'bar' }
foo.new>>bar;
but that worked (displayed bar).
2 If you didn't get to my Take #1 conclusion yourself, perhaps that was was because your MRE wasn't very M? If you did arrive at the same point (cf "solution attempt #1 does NOT get called" in your MRE) then please read and, for future SOs, take to heart, the wisdom of "Explain ... any difficulties that have prevented you from solving it yourself".

Object, roles and multiple dispatch

I'm trying to use multiple dispatch to overload and use methods within composed classes. Here's the implementation:
role A {
has $!b;
submethod BUILD( :$!b ) {}
multi method bar () {
return $!b;
}
}
class B does A {
submethod BUILD( :$!b ) {}
multi method bar() {
return " * " ~ callsame ~ " * ";
}
}
my $a = A.new( b => 33);
say $a.bar();
my $b = B.new( b => 33 );
say $b.bar();
This fails, however, with:
Calling callsame(Str) will never work with declared signature ()
(I really have no idea why callsame uses Str as a signature). Changing the method bar to use callwith:
multi method bar() {
return " * " ~ callwith() ~ " * ";
}
Simply does not work:
Use of Nil in string context
in method bar at multi.p6 line 18
* *
Is there any special way to work with call* within roles/classes?
The first issue is a matter of syntax. A listop function call parses an argument list after it, starting with a term, so this:
return " * " ~ callsame ~ " * ";
Groups like this:
return " * " ~ callsame(~ " * ");
And so you're calling the ~ prefix operator on " * ", which is where the Str argument it complains about comes from.
Ultimately, however, the issue here is a misunderstanding of the semantics of role composition and/or deferral. Consider a non-multi case:
role R { method m() { say 1; callsame() } }
class B { method m() { say 2; callsame() } }
class C is B does R { method m() { say 3; callsame(); } }
C.m
This outputs:
3
2
Notice how 1 is never reached. This is because role composition is flattening: it's as if the code from the role were put into the class. When the class already has a method of that name, then it is taken in favor of the one in the role.
If we put multi on each of them:
role R { multi method m() { say 1; callsame() } }
class B { multi method m() { say 2; callsame() } }
class C is B does R { multi method m() { say 3; callsame(); } }
C.m
The behavior is preserved:
3
2
Because the role composer accounts for the long name of the multi method - that is, accounting for the signature. Since they are the very same, then the one in the class wins. Were it to retain both, we'd end up with the initial call resulting in an ambiguous dispatch error!
Deferral with nextsame, callsame, nextwith, and callwith all iterate through the possible things we could have dispatched to.
In the case of a non-multi method, that is achieved by walking the MRO; since the method from the role was not composed, then it doesn't appear in any class in the MRO (nothing that only classes appear in the MRO, since roles are flattened away at composition time).
In the case of a multi method, we instead walk the set of candidates that would have accepted the arguments of the initial dispatch. Again, since the identically long-named method in the class was chosen in favor of the role one at composition time, the one from the role simply isn't in consideration for the dispatch in the first place: it isn't in the candidate list of the proto, and so won't be deferred to.

Adding user mode types for Perl 6 NativeCall structs

The Perl 6 docs list a bunch of types. Some of them, such as Str, have more complicated box/unbox behaviors.
Is it possible to define my own type, specifying my own routines for the box/unboxing? For a particular project, I have a bunch of types I'm reusing, and basically cut/pasting my accessor functions over and over.
For example, the C Struct uses a time_t, and I plug in accessor methods to go to/from a DateTime. Another example is a comma-separated list, I'd like to go to/from an Array and take care of the split/join automagically.
Is there a better way to do this?
Edit: Add Example:
constant time_t = uint64;
constant FooType_t = uint16;
enum FooType <A B C>;
class Foo is repr('CStruct') is rw
{
has uint32 $.id;
has Str $.name;
has FooType_t $.type;
has time_t $.time;
method name(Str $n?) {
$!name := $n with $n;
$!name;
}
method type(FooType $t?) {
$!type = $t with $t;
FooType($!type);
}
method time(DateTime $d?) {
$!time = .Instant.to-posix[0].Int with $d;
DateTime.new($!time)
}
}
my $f = Foo.new;
$f.id = 12;
$f.name('myname');
$f.type(B);
$f.time(DateTime.new('2000-01-01T12:34:56Z'));
say "$f.id() $f.name() $f.type() $f.time()";
# 12 myname B 2000-01-01T12:34:56Z
This works, I can set the various fields of the CStruct in Perl-ish ways (no lvalue, but I can pass them in as parameters).
Now I want to use time_t, FooType_t, etc. for many fields in a lot of structs and have them act the same way. Is there a better way other than to just copy those methods over and over?
Maybe macros could help here? I haven't mastered them yet.
You could write a trait that handles automatic attribute conversion on fetching or storing the attribute. The following should get you started:
multi sub trait_mod:<is>(Attribute:D $attr, :$autoconv!) {
use nqp;
my $name := $attr.name;
$attr.package.^add_method: $name.substr(2), do given $attr.type {
when .REPR eq 'P6int' {
method () is rw {
my $self := self;
Proxy.new:
FETCH => method () {
$autoconv.out(nqp::getattr_i($self, $self.WHAT, $name));
},
STORE => method ($_) {
nqp::bindattr_i($self, $self.WHAT, $name,
nqp::decont($autoconv.in($_)));
}
}
}
default {
die "FIXME: no idea how to handle {.^name}";
}
}
}
For example, take your use case of time_t:
constant time_t = uint64;
class CTimeConversion {
multi method in(Int $_ --> time_t) { $_ }
multi method in(DateTime $_ --> time_t) { .posix }
method out(time_t $_ --> DateTime) { DateTime.new($_) }
}
class CTimeSpan is repr<CStruct> {
has time_t $.start is autoconv(CTimeConversion);
has time_t $.end is autoconv(CTimeConversion);
}
Finally, some example code to show it works:
my $span = CTimeSpan.new;
say $span;
say $span.end;
$span.end = DateTime.now;
say $span;
say $span.end;

How does one write custom accessor methods in Perl6?

How does one write custom accessor methods in Perl6?
If I have this class:
class Wizard {
has Int $.mana is rw;
}
I can do this:
my Wizard $gandalf .= new;
$gandalf.mana = 150;
Let's say I want to add a little check to a setter in my Perl6 class without giving up the $gandalf.mana = 150; notation (in other words, I don't want to write this: $gandalf.setMana(150);). The program should die, if it tries to set a negative mana. How do I do this? The Perl6 documentation just mentions it is possible to write custom accessors, but does not say how.
With more recent versions of Rakudo there is a subset named UInt that restricts it to positive values.
class Wizard {
has UInt $.mana is rw;
}
So that you're not stuck in a lurch if you need to something like this; here is how that is defined:
( you can leave off the my, but I wanted to show you the actual line from the Rakudo source )
my subset UInt of Int where * >= 0;
You could also do this:
class Wizard {
has Int $.mana is rw where * >= 0;
}
I would like to point out that the * >= 0 in the where constraint is just a short way to create a Callable.
You could have any of the following as a where constraint:
... where &subroutine # a subroutine that returns a true value for positive values
... where { $_ >= 0 }
... where -> $a { $a >= 0 }
... where { $^a >= 0 }
... where $_ >= 0 # statements also work ( 「$_」 is set to the value it's testing )
( If you wanted it to just not be zero you could also use ... where &prefix:<?> which is probably better spelled as ... where ?* or ... where * !== 0 )
If you feel like being annoying to people using your code you could also do this.
class Wizard {
has UInt $.mana is rw where Bool.pick; # accepts changes randomly
}
If you want to make sure the value "makes sense" when looking at all of the values in the class in aggregate, you will have to go to a lot more work.
( It may require a lot more knowledge of the implementation as well )
class Wizard {
has Int $.mana; # use . instead of ! for better `.perl` representation
# overwrite the method the attribute declaration added
method mana () is rw {
Proxy.new(
FETCH => -> $ { $!mana },
STORE => -> $, Int $new {
die 'invalid mana' unless $new >= 0; # placeholder for a better error
$!mana = $new
}
)
}
}
You can get the same accessor interface that saying $.mana provides by declaring a method is rw. Then you can wrap a proxy around the underlying attribute like so:
#!/usr/bin/env perl6
use v6;
use Test;
plan 2;
class Wizard {
has Int $!mana;
method mana() is rw {
return Proxy.new:
FETCH => sub ($) { return $!mana },
STORE => sub ($, $mana) {
die "It's over 9000!" if ($mana // 0) > 9000;
$!mana = $mana;
}
}
}
my Wizard $gandalf .= new;
$gandalf.mana = 150;
ok $gandalf.mana == 150, 'Updating mana works';
throws_like sub {
$gandalf.mana = 9001;
}, X::AdHoc, 'Too much mana is too much';
Proxy is basically a way to intercept read and write calls to storage and do something other than the default behavior. As their capitalization suggests, FETCH and STORE are called automatically by Perl to resolve expressions like $gandalf.mana = $gandalf.mana + 5.
There's a fuller discussion, including whether you should even attempt this, at PerlMonks. I would recommend against the above -- and public rw attributes in general. It's more a display of what it is possible to express in the language than a useful tool.

Convert Namespace to a single proc

I have a set of procs and a namespace as you can see below:
namespace eval ::_API {
if {[info exists ::_API::API_ids]} {
catch {API erase -ids [array names ::_API::API_ids]}
}
catch {unset API_ids}
array set API_ids ""
}
proc ::_API::erase { } {
foreach id [array names ::_API::API_ids] {
if {::_API::API_ids($id) == 0} {
continue
}
if {[catch {API -id $id -redraw 0}] != 0} {
set ::_API::API_ids($id) 0
}
}
Redraw ;# I'm not concerned about this part
# and I'm fairly certain it can be ignored
}
proc erase { } {
::_API ::erase
}
::_API::API_ids is an array that contains points (e.g. 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15). What the script does is erase points in a table.
I want to convert the namespace ::_API into a proc so that I can use a GUI button to call the proc. It is currently directly after some other scripts (which map the points in the table) and I want to erase them only when required; i.e. when the button will be pressed.
I already tried running ::_API::erase directly but it is not working:
proc ::_API::erase { } {
foreach id [array names ::_API::API_ids] {
if {::_API::API_ids($id) == 0} {
continue
}
if {[catch {API -id $id -redraw 0}] != 0} {
set ::_API::API_ids($id) 0
}
}
Redraw
}
I think that there might be something I'm missing about the namespace. I tried reading the documentation but I don't quite understand really how they work.
The first thing that you really must do is use variable to declare the variable. For some fairly ugly reasons, failing to do that can cause “fun” with variable resolution to make things happen in ways you don't expect:
namespace eval ::_API {
variable API_ids; ##### <<<<<<< THIS <<<<<<< #####
if {[info exists ::_API::API_ids]} {
catch {API erase -ids [array names ::_API::API_ids]}
}
catch {unset API_ids}
array set API_ids ""
}
Secondly, you probably ought to actually think in terms of using real OO for this rather than trying to fake it. For example, with TclOO you'd be writing something like:
oo::class create APIClass {
variable ids
constructor {} {
array set ids {}
}
method erase {} {
foreach id [array names ids] {
if {$ids($id) == 0} continue
if {[catch {
API -id $id -redraw 0
}]} {
set ids($id) 0
}
}
Redraw
}
# Allow something to reference the ids variable from the outside world
method reference {} {
return [my varname ids]
}
}
APIClass create _API
# [_API erase] will call the erase method on the _API object
This simplifies things quite a bit, and in fact you can think in terms of coupling the drawing and the data management quite a lot closer than I've done above; it's just indicative of what you can do. (I find that it makes stuff a lot simpler when I use objects, as they've got a much stronger sense of lifecycle about them than ordinary namespaces.)
What you mean is you want to convert the namespace initialization code into a procedure. The following example should achieve that.
namespace eval ::_API {
}
proc ::_API::initialize {} {
variable API_ids
if {[info exists API_ids]} {
catch {API erase -ids [array names API_ids]}
unset API_ids
}
array set API_ids ""
}
... more definitions ...
::_API::initialize
We start by declaring the namespace. Then replicate the original code in a procedure. As there is no point unsetting a non-existent variable, we move unset into the block that only runs if the variable exists.
At the end of the namespace definitions, initialize the namespace by calling its initialization function.