Most trusting

I was looking for a neat way to specify units when working with numbers. When doing dimensional analysis, many physicists like to put units into square brackets to create an additional namespace. We can do the same.

use v6.d;

class Unit { ... }

class SiInt is Int {
    trusts GLOBAL;
    trusts Unit;

    has Unit $!unit;
    method !unit { return-rw $!unit }

    method new(CORE::Int $new) { nextsame }
    method Str { self.Int::Str ~ $!unit.suffix }

    method ACCEPTS(Unit:U $u) { $!unit === $u }
}

class Unit {
    our $.suffix = '';
    our $.long-name = "unit-less";

    method ACCEPTS(SiInt $si) { $si!SiInt::unit === self }
}

class m is Unit { our $.suffix = 'm'; our $.long-name = 'Meter'; }

multi sub postcircumfix:<[ ]>(SiInt $obj, Unit:U $unit) {
    $obj!SiInt::unit === Unit ?? ($obj!SiInt::unit = $unit)
        !! fail(‘Sorry, units can only be set, not changed.’);

    $obj
}
multi sub postcircumfix:<[ ]>(Int $value, Unit:U $unit) { SiInt.new($value)[$unit] }

constant Int = SiInt; # intentional shadowing of CORE::Int

my $i = 42[m];
put [$i, $i.^name]; # 42m SiInt
my Int() $a = 1;
put [$a, $a.^name]; # 1 SiInt

class s is Unit { our $.suffix = 's'; our $.long-name = 'Seconds'; }
multi sub infix:<+>(SiInt $l, SiInt $r) {
    $l!SiInt::unit === Unit ?? callsame()[$r!SiInt::unit]
    !! $r!SiInt::unit === Unit ?? callsame()[$l!SiInt::unit]
        !! $l!SiInt::unit === $r!SiInt::unit ?? nextsame()
           !! fail(„Unit mismatch between $l and $r“)
}

my $s = 60[s];

say $i + $a; # 43m
say $s + $i; # Unit mismatch between 60s and 42m

The idea is to have a numerical type that is by default unit-less. A unit can be added (but not changed) with square bracket postcircumfix. Since I add type-objects for each unit, I don’t have to mess around with strings and can multi-dispatch if needed. Since I want direct access to the unit, I tell the class to trust the package the operators are defined in. (This could be a module, of course.) What happens to be an ENODOC.

I have to use a forward declaration to get ACCEPTS to get hold of $!unit. Subsequently, multi-dispatch works just fine.

multi sub fancy(Int $value where m) { #`[fancy calculation goes here] }
multi sub fancy(Int) { fail ‘Can only be fancy with Unit "m".’ }
fancy($i);

Since SiInt is just an Int all built-ins will work, so long the unit is restored after using them. Being able to trust operators allows them to access the entire class, without having to cheat with use nqp;.

Because Raku treats types as values, I can calculate a compound unit.

class Meters-per-Second is Unit { our $.suffix = 'm/s'; our $.long-name = 'Meters per Second'; }
multi sub infix:</>(m, s) { Meters-per-Second }

sub speed($d where m, $t where s) { ($d / $t).Int.[m/s] }

my Int $fast = speed(500[m], 1[s]);
say $fast; # 500m/s

I’m quite pleased with being able to extend the type-system so easily without having to invent a complete new DSL. This aids composability greatly.

Plucking strings

This is a correction and follow-up of my previous post. The ever helpful vrurg provided a simplification to my transformative role. I added some evil to it, mostly for nicer looking introspection.

role Trans[::From, ::To, &c] {
    has To $.value;
    method COERCE(From:D $old) {
        self.new(:value($old.&c))
    }

    unless ::?ROLE.^declares_method(my $mname = To.^name) {
        ::?ROLE.^add_method: $mname, ('my method ' ~ $mname ~ '(--> To) { $.value }').EVAL;
    }
}

By checking if the role contains a method already, I don’t need to fool around with the method table any more. I use .EVAL to compose the method name properly. Rakudo doesn’t care, but a human looking at the method name does not need to be confused. Please note the absence of use MONKEY;. The method form of EVAL doesn’t require it. It is safe to assume code not to be safe.

Task 2 can be written as a naive algorithm. Keep the stickers that contain characters that are also in the target word. Check if all letters in the target word are in the kept stickers. If so, show them or complain.

Again, I need a way to turn words into Sets. I shall do so by invoking the coercion-protocol with a new-method.

class Plucked {
    has $.str;
    has @.chars;

    method new(Str:D $s) { callwith  :str($s), :chars($s.comb) }
    method gist { $!str ~ ' ' ~ @!chars.pairs».&{ .key ~ ' ' ~ .value } }
    method Str { $.str }
    method Set { @.chars.Set }
    method AT-POS($pos) { @.chars.AT-POS($pos) }
    method AT-KEY($key) { @.chars.grep( * eq $key ) }
}

constant PC = Plucked(Str:D);

for [
    ('perl','raku','python'), 'peon';
    ('love','hate','angry'), 'goat';
    ('come','nation','delta'), 'accommodation';
    ('come','country','delta'), 'accommodation'
] -> [ @stickers, PC $word ] {
    my @keep;
    for @stickers -> PC $sticker {
        @keep.push($sticker) if $word ∩ $sticker;
    }
    if ([∪] @keep) ⊇ $word {
        put „"$word" can be made with "$@keep"“;
    } else {
        my $missing = $word ∖ ([∪] @keep);
        put „"$word" can not be made, "$missing" is missing“;
    }
}

The helper class Plucked knows how to dissect Strs and turn them into Sets and Strs. Since laziness is a virtue, I reduce the amount of typing by storing the coercion-type in a constant. Then I write the naive algorithm down.

I didn’t know that I can store coercion-types the same way as other type-objects in a constant. It just DWIMed and that pleases me greatly.

Reducing sets

This week´s PWC asks us for hexadecimal words and distinctly different directories.

sub term:<pwc-166-1> {
    sub less-substitutions-then ($_, $n) {
        .subst(/<-[olist]>/, :g, '').chars < $n
    }

    '/usr/share/dict/words'.IO.words.race\
        .grep({.chars ≤ 8 && .&less-substitutions-then(4)})\
        .map(*.trans(<o l i s t> => <0 1 1 5 7>))\
        .grep(/^ <[0..9 a..f A..F]>+ $/)\
        .sort(-*.chars)\
        .say;
};

Once again, we write the algorithm down. Get the words, drop anything longer then 8 chars or what would need more then 4 substitutions. Then do the substitutions and grep anything that looks like a hexadecimal numeral. Sort for good measure and output the first 100 elements.

The second task provides us with a little challenge. We need to mock listing directories and working with them. Since dir returns a sequence of IO::Path I can create those by hand and mixin a role that mimics some filesystem operations. I can overload dir to provide a drop-in replacement.

sub term:<pwc-166-2> {
    sub basename(IO::Path $_) { .basename ~ (.d ?? '/' !! '') }
    sub pad(Str $_, $width, $padding = ' ') { .Str ~ $padding x ($width - .chars) }

    sub dir(Str $name) {
        sub mock-file(*@names) { @names.map({ IO::Path.new($_) but role :: { method f ( --> True ) {}; method e ( --> True ) {} } } ) }
        sub mock-dir(*@names) { @names.map({ IO::Path.new($_) but role :: { method d ( --> True ) {}; method e ( --> True) {} } }) }

        constant %dirs = dir_a => flat(mock-file(<Arial.ttf Comic_Sans.ttf Georgia.ttf Helvetica.ttf Impact.otf Verdana.ttf>), mock-dir(<Old_Fonts>)),
                         dir_b => mock-file(<Arial.ttf Comic_Sans.ttf Courier_New.ttf Helvetica.ttf Impact.otf Tahoma.ttf Verdana.ttf>),
                         dir_c => mock-file(<Arial.ttf Courier_New.ttf Helvetica.ttf Impact.otf Monaco.ttf Verdana.ttf>);

        %dirs{$name}
    }

    sub dir-diff(+@dirs) {
        my @content = @dirs».&dir».&basename;
        my @relevant = (([∪] @content) ∖ [∩] @content).keys.sort;

        my @columns = @content.map(-> @col { @relevant.map({ $_ ∈ @col ?? $_ !! '' }) });
        my $col-width = [max] @columns[*;*]».chars;

        put @dirs».&pad($col-width).join(' | ');
        put (''.&pad($col-width, '-') xx 3).join('-+-');
        .put for ([Z] @columns)».&pad($col-width)».join(' | ');
    }

    dir-diff(<dir_a dir_b dir_c>);
};

I’m asked to add a / to directories and do so with a custom basename. The rest is liberal application of set theory. Only names that don’t show up in all directories are relevant. Columns are created by matching the content of each directory against the relevant names. The width of columns is the longest string. The header is put on screen. To output the columns line by line, x and y are flipped with [Z].

After careful study of the solutions written in other languages, I believe it is fair to call Raku an eco-friendly language. Our keyboards are going to last at least twice a long.

Typed filters

The Discord Raku bot is now also an IRC -> Discord bridge. To handle the streams of messages I use a react-block with a few whenevers. I would like to handle filtering of debug output from API::Discord in there as well, without disrupting something simple like printing to the terminal.

In my last post I showed how I can control the behaviour of a module with the use statement. The next step is to divert writes to $*ERR to a Supply.

my $active = False;

sub debug-print(|c) {
    $*ERR.print: |c if $active;
}

sub debug-print-supply(Supply $in? --> Supply:D) {
    my $result = $in // Supplier::Preserving.new;

    &debug-print.wrap(-> |c {
        $result.emit: |c
    });

    $result.Supply
}

multi sub EXPORT('FROM-MODULE') {
    %(
        '&debug-print' => &debug-print,
    )
}

multi sub EXPORT() {
    $active = True;

    %(
        '&debug-print' => &debug-print-supply,
    )
}

As long as the user of the module doesn’t call debug-print, we have the simple case of writing to $*ERR. When debug-print is called, we divert the stream into a Supply. If no Supply is supplied, we create one. To be able to filter output a role is created in API::Discord::Debug.

role LogEventType is export {}

This role is indeed empty and so are the roles that are created to provide filters.

unit module Testmodule;

use API::Discord::Debug <FROM-MODULE>;

role HEARTBEAT does LogEventType is export {}
role PING does HEARTBEAT does LogEventType is export {}

start loop {
    sleep ¼;
    debug-print("ping" but PING);
    debug-print("pong" but PONG) unless 10.rand < 2;
}

So we create a Str and mixin a role, what is a type object we can check against.

use API::Discord::Debug;
use Testmodule;

react {
    my  $pings = 0;

    whenever debug-say().merge(debug-print()) {
        when PING { $pings++; }
        when PONG { $pings--; }
        default { .note }
    }

    whenever Supply.interval(5) {
        say „$pings heartbeats are lost“ if $pings > 1;
    }
}

Mixing in an empty role wont upset any unsuspecting bystander and type checks compose well. Here I use them with when/default, a multi dispatch would work as well. Introspection can be done with .WHAT.say.

On CPAN we can find many “complete” modules that kill a specific problem once and for all. For many of those, there tends to be another module suffixed with ::Simple. Simple stuff should be simple because we can’t buy any more days in this life. We also don’t take anything with us. I hope I can leave something simple behind instead.

Late early bound

My last post got at least two people thinking. I made the suggestion to add a sub called pretty-print to make the resulting text/html human friendly. Since this is a nice name, making it a multi seams a polite move.

multi sub pretty-print(html::("NON-QUOTE") $html) { ... }

Since html is a singleton of an anonymous class, we can’t easily refer to the role NON-QUOTE within. We use a runtime lookup to get hold of the type at compile time. Said compile time is actually quite late. It happens at the same time constants are evaluated. Hence, html‘s guts can be queried, because that constant expression is further up in the file.

I did not know that type constraints are turned into type objects that late and found it difficult to explain. We may have to invent time travel to learn the time traveller language to be able to explain the order of operations of Rakudo.

Awaiting a bugfix

When using Proc::Async we need to await while waiting for a fix for R#3817. While adding many tests to Shell::Piping I got a flapper on Travis. After my last misadvanture while testing async code I learned to use stress -c 30 to make sure that OS threads are congested. And sure enough, I got the same tests to fail then on Travis. A workaround is to await after reading form Proc::Async.stdout. In my code that looks like the following.

for $.proc-out-stdout.lines {
    my $value := &.code.($_);
    my $processed = $value === Nil ?? ‚‘ !! $value ~ "\n";
    await $.proc-in.write: $processed.encode with $.proc-in;
  # ^^^^^ WORKAROUND for R#3817
}

I then had to add a piece of odd code at another place to have something to await on.

method write($blob) { my $p = Promise.new; $p.keep; a.push: $blob.decode.chomp; $p }

The Promise is really just there so we can nudge Rakudo to have a good look at its threads. If you are using Proc::Async in your code please check for .write and test it on a system with more work then cores. You wont get an error with this bug. It will just silently drop values that are send via .write to another process or fetched via .stdout.lines. Good hunting!

Conditional whenever

I wrote a script to filter iostat because the latter either displays too much or too little. It also doesn’t know about bcache. I wanted to have the script react the same way to pressing q then top, atop or iotop. But it should only watch the keyboard and quit when $*OUT is a terminal. First we need to read the keyboard.

whenever key-pressed(:!echo) {
    when 'q' | 'Q' { done }
}

Now we got a few options to add a check for an attached terminal

if $*OUT.t {
    whenever key-pressed(:!echo) {
        when 'q' | 'Q' { done }
    }
}
$*OUT.t && do whenever key-pressed(:!echo) {
    when 'q' | 'Q' { done }
}
do whenever key-pressed(:!echo) {
    when 'q' | 'Q' { done }
} if $*OUT.t

The last one kind of lines up with other whenever blocks but the condition gets harder to read. At first I thought it wont be possible to use ?? !! because whenever always wants to run .tap on the parameter. But then I remembered that we use 0x90 to tell a CPU to do nothing. If we get a Supply that does nothing we can opt out of doing something.

constant NOP = Supplier.new;
whenever $*OUT.t ?? key-pressed(:!echo) !! NOP {
    when 'q' | 'Q' { done }
}

Now it neatly lines up with other whenever blocks.

As a member of the Perl family Perl 6 has more then one way to do it. Most of them look a big odd though.

Threading nqp through a channel

Given that nqp is faster then plain Perl 6 and threads combining the two should give us some decent speed. Using a Supply as promised in the last post wouldn’t really help. The emit will block until the internal queue of the Supply is cleared. If we want to process files recursively the filesystem might stall just after the recursing thread is unblocked. If we are putting pressure on the filesystem in the consumer, we are better of with a Channel that is swiftly filled with file paths.

Let’s start with a simulated consumer that will stall every now end then and takes the Channel in $c.

my @files;
react {
    whenever $c -> $path {
        @files.push: $path;
        sleep 1 if rand < 0.00001;
    }
}

If we would pump out paths as quickly as possible we could fill quite a bit of RAM and put a lot of pressure on the CPU caches. After some trial and error I found that sleeping befor the .send on the Channel helps when there are more then 64 worker threads waiting to be put onto machine threads. That information is accessible via Telemetry::Instrument::ThreadPool::Snap.new<gtq>.

my $c = Channel.new;
start {
    my @dirs = '/snapshots/home-2019-01-29';
    while @dirs.shift -> str $dir {
        my Mu $dirh := nqp::opendir(nqp::unbox_s($dir));
        while my str $name = nqp::nextfiledir($dirh) {
            next if $name eq '.' | '..';
            my str $abs-path = nqp::concat( nqp::concat($dir, '/'), $name);
            next if nqp::fileislink($abs-path);
            if Telemetry::Instrument::ThreadPool::Snap.new<gtq> > 64 {
                say Telemetry::Instrument::ThreadPool::Snap.new<gtq>;
                say 'sleeping';
                sleep 0.1;
        }
        $c.send($abs-path) if nqp::stat($abs-path, nqp::const::STAT_ISREG);
        @dirs.push: $abs-path if nqp::stat($abs-path, nqp::const::STAT_ISDIR);
    }
    CATCH { default { put BOLD .Str, ' ⟨', $dir, '⟩' } }
    nqp::closedir($dirh); }
    $c.close;
}

Sleeping for 0.1s before sending the next value is a bit naive. It would be better to watch the number of waiting workers and only continue when it has dropped below 64. But that is a task for a differnt module. We don’t really have a middle ground in Perl 6 between Supply with it’s blocking nature and the value pumping Channel. So such a module might be actually quite useful.

But that will have to wait. I seam to have stepped on a bug in IO::Handle.read while working with large binary files. We got tons of tests on roast that deal with small data. Working with large data isn’t well tested and I wonder what monsters are lurking there.

Issue All The Things

While on her epic quest to clean up the meta part of the ecosystem samvc send me a few pull requests. That raised the question which of my modules have open issues. Github is quite eager to list you many things but lacks the ability to show issues for a group of repos. Once again things fell into place.

Some time ago I made a meta module to save a few clicks when testing modules once a week. What means I have a list of modules I care about already.

perl6 -e 'use META6; use META6::bin :TERM :HELPER;\\
for META6.new(file => "$*HOME/projects/perl6/gfldex-meta-zef-test/META6.json").<depends> -> $name {\\
    say BOLD $name;\\
}'

META6::bin didn’t know about Github issues, what was easily solved, including retries on timeouts of the github api. Now I can feed the module names into &MAIN and get a list of issues.

perl6 -e 'use META6; use META6::bin :TERM :HELPER;\\
for META6.new(file => "$*HOME/projects/perl6/gfldex-meta-zef-test/META6.json").<depends> -> $name {\\
    say BOLD $name;\\
    try META6::bin::MAIN(:issues, :module($name), :one-line, :url);\\
}'

I switfly went to merge the pull requests.

Test::META
[open] Add License checks and use new META license spec [10d] ⟨https://github.com/jonathanstowe/Test-META/pull/21⟩
[open] warn on source [35d] ⟨https://github.com/jonathanstowe/Test-META/issues/20⟩
[open] warn on empty description [37d] ⟨https://github.com/jonathanstowe/Test-META/issues/19⟩
[open] check if source-url is accessible [37d] ⟨https://github.com/jonathanstowe/Test-META/issues/18⟩
[open] Check `perl` version [135d] ⟨https://github.com/jonathanstowe/Test-META/issues/14⟩
[open] Report missing modules? [1y] ⟨https://github.com/jonathanstowe/Test-META/issues/8⟩
[open] Add :strict-versions switch [1y] ⟨https://github.com/jonathanstowe/Test-META/issues/7⟩
[open] Test harder that "provides" is sane [1y] ⟨https://github.com/jonathanstowe/Test-META/issues/6⟩
Typesafe::XHTML::Writer
Rakudo::Slippy::Semilist
Slippy::Semilist
Github timed out, trying again 1/3.
Github timed out, trying again 2/3.
Github timed out, giving up.
Operator::defined-alternation
Concurrent::Channelify
[open] Use SPDX identifier in license field of META6.json [3d] ⟨https://github.com/gfldex/perl6-concurrent-channelify/pull/1⟩
Concurrent::File::Find
[open] Use SPDX identifier in license field of META6.json [3d] ⟨https://github.com/gfldex/perl6-concurrent-file-find/pull/1⟩
XHTML::Writer
Github timed out, trying again 1/3.
Typesafe::HTML
Git::Config
Proc::Async::Timeout
Github timed out, trying again 1/3.
[open] Use SPDX identifier in license field of META6.json [9d] ⟨https://github.com/gfldex/perl6-proc-async-timeout/pull/1⟩

To check the issues of any project that got a META6.json run meta6 --issues. To check if there are issues for a given module in the ecosystem use meta6 --issues --module=Your::Module::Name

UPDATE:

As requested by timotimo, meta6 --issues --one-line --url --deps will list all issues of the repo and all issues of the dependencies listed in META6.json.

You can call me Whatever you like

The docs spend many words to explain in great detail what a Whatever is and how to use it from the caller perspective. There are quite a few ways to support Whatever as a callee as I shall explain.

Whatever can be used to express “all of the things”. In that case we ask for the type object that is Whatever.

sub gimmi(Whatever) {};
gimmi(*);

Any expression that contains a Whatever * will be turned into a thunk. The latter happens to be a block without a local scope (kind of, it can be turned into a block when captured). We can ask specifically for a WhateverCode to accept Whatever-expressions.

sub compute-all-the-things(WhateverCode $c) { $c(42) }
say compute-all-the-things(*-1);
say (try say compute-all-the-things({$_ - 1})) // 'failed';
# OUTPUT: «41␤failed␤»

We could also ask for a Block or a Method as both come preloaded with one parameter. If we need a WhateverCode with more then one argument we have to be precise because the compiler can’t match a Callable sub-signature with a WhateverCode.

sub picky(WhateverCode $c where .arity == 2 || fail("two stars in that expession please") ) {
    $c.(1, 2)
}
say picky(*-*);
# OUTPUT: «-1␤»
say (try picky(*-1)) // $!;
# OUTPUT: «two stars in that expession please␤  in sub picky at …»

The same works with a Callable constraint, leaving the programmer more freedom what to supply.

sub picky(&c where .arity == 2) { c(1, 2) }

There are quite a few things a WhateverCode can’t do.

sub faily(WhateverCode $c) { $c.(1) }
say (try faily( return * )) // $!.^name;
# OUTPUT: «X::ControlFlow::Return␤»

The compiler can take advantage of that and provide compile time errors or get things done a little bit qicker. So trading the flexibility of Callable for a stricter WhateverCode constraint may make sense.