Archive
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 whenever
s. 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 constant
s 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: «41failed»
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.
You must be logged in to post a comment.