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.

Dealing with Fallout

The much welcome and overdue sanification of the IO-subsystem lead to some fallout in some of my code that was enjoyably easy to fix.

Some IO-operations used to return False or undefined values on errors returned from the OS. Those have been fixed to return Failure. As a result some idioms don’t work as they used to.

my $v = §some-filename.txt".IO.open.?slurp // 'sane default';

The conditional method call operator .? does not defuse Failure as a result the whole expression blows up when an error occures. Luckily try can be used as a statement, which will return Nil, so we can still use the defined-or-operator // to assign default values.

my $v = (try "some-filename.txt".IO.open.slurpy) // 'sane default';

The rational to have IO-operations throw explosives is simple. Filesystem dealings can not be atomic (at least seen from the runtime) and can fail unexpectetly due to cable tripping. By packaging exceptions in Failure objects Perl 6 allows us to turn them back into undefined values as we please.

Slipping in a Config File

I wanted to add a config file to META6::bin without adding another dependency and without adding a grammar or other forms of fancy (and therefore time consuming) parsers. As it turns out, .split and friends are more then enough to get the job done.

# META6::bin config file

general.timeout = 60
git.timeout = 120
git.protocol = https

That’s how the file should look like and I wanted a multidim Hash in the end to query values like %config<git><timeout>.

our sub read-cfg($path) is export(:HELPER) {
    use Slippy::Semilist;

    return unless $path.IO.e;

    my %h;
    slurp($path).lines\
        ».chomp\
        .grep(!*.starts-with('#'))\
        .grep(*.chars)\
        ».split(/\s* '=' \s*/)\
        .flat.map(-> $k, $v { %h{||$k.split('.').cache} = $v });

    %h
}

We slurp in the whole file and process it line by line. All newlines are removed and any line that starts with a # or is empty is skipped. We separate values and keys by = and use a Semilist Slip to build the multidim Hash. Abusing a .map that doesn’t return values is a bit smelly but keeps all operations in order.

A Semilist is the thing you can find in %hash{1;2;3} (same for arrays) to express multi-dimentionallity. Just using a normal list wont cut it because a list is a valid key for a Hash.

I had Rakudo::Slippy::Semilist laying around for quite some time but never really used it much because it’s cheating by using nqp-ops to get some decent speed. As it turned out it’s not really the operations on a Hash as the circumfix:<{ }>-operator itself that is causing a 20x speed drop. By calling .EXISTS-KEY and .BIND-KEY directly the speed hit shrinks down to 7% over a nqp-implementation.

It’s one of those cases where things fall into place with Perl 6. Being able to define my own operator in conjunction with ». allows to keep the code flowing in the order of thoughs instead of breaking it up into nested loops.