Skip to content

Instantly share code, notes, and snippets.

@jbarrett
Last active November 11, 2023 11:38
Show Gist options
  • Save jbarrett/b6cba95ceb8bdb93ab9adaf16c1b3f5d to your computer and use it in GitHub Desktop.
Save jbarrett/b6cba95ceb8bdb93ab9adaf16c1b3f5d to your computer and use it in GitHub Desktop.
Multimethod hack - example of pluggable keyword
die "This code should not be used, ever!" unless $ENV{MULTIMETHOD_DEATHWISH};
package Multimethod;
use v5.38;
use experimental qw/ try /;
use List::Util qw/ uniq /;
use List::MoreUtils qw/ each_array /;
use Scalar::Util qw/ blessed /;
use Keyword::Declare;
use Object::Pad::MOP::Class qw/ :experimental(mop) /;
use Types::Standard;
my $methods = {};
my $checkers = {};
sub _extract_signature( $raw_params ) {
$raw_params =~ s/^\(//;
$raw_params =~ s/\)$//;
+{
map {
my @param = split " ", $_;
$param[1]
? ( $param[1] => $param[0] )
: ( $param[0] => undef )
} split ",", $raw_params
}
}
sub _inject_proxy_method( $class, $method ) {
return if $class->can( $method );
my $meta = Object::Pad::MOP::Class->for_class( $class );
$meta->add_method(
"$method",
sub {
Multimethod::delegate( $class, $method, @_ )
}
);
}
sub _build_type_checkers( @types ) {
for my $type ( uniq sort grep { $_ } @types ) {
next if $checkers->{ $type };
$checkers->{ $type } = sub( $datum ) {
state $ts_type = Types::Standard->can( $type );
$ts_type
? $ts_type->()->assert_valid( $datum )
: blessed $datum && $datum->isa( $type )
or die("$datum is not an instance of $type");
};
}
}
sub _find_signature_match( $delegates, @params ) {
OUTER: for my $delegate ( $delegates->@* ) {
my @types = values $delegate->{ signature }->%*;
# return unless @types == @params;
my $iter = each_array( @types, @params );
while ( my ( $type, $param ) = $iter->() ) {
next unless $type;
try {
$checkers->{ $type }->( $param );
} catch( $e ) {
next OUTER;
}
}
return $delegate->{ method };
}
}
sub delegate( $class, $method, $instance, @params ) {
my $delegates = $methods->{ $class }->{ $method };
my $delegate_method = _find_signature_match( $delegates, @params );
die "No delegate method found for ${class}::$method" unless $delegate_method;
$instance->$delegate_method( @params );
}
sub import {
my $class = caller();
keyword multi (
/sub|method/ $sub,
Ident $method,
Attributes? $attribs,
List? $raw_params,
) {
my $signature = _extract_signature( $raw_params );
my $param_string = join ',', keys $signature->%*;
my @types = values $signature->%*;
my $signature_name = join '_', map { $_ // 'undef' } @types;
my $target_method = "_multimethod_${signature_name}_$method";
die "Ambiguous signature in $method declaration"
if $class->can( $target_method );
$methods->{ $class }->{ $method } //= [];
push $methods->{ $class }->{ $method }->@*, {
signature => $signature, method => $target_method
};
_build_type_checkers( @types );
_inject_proxy_method( $class, $method );
"$sub $target_method $attribs ( $param_string )";
}
}
use lib '.';
use v5.38.0;
use Test2::V0;
use Object::Pad;
# This is not a comprehensive test suit - it's more a demo
# Two classes to check namespaces are set up as expected
class One {
use Multimethod;
method this() { "this" }
multi method that( Int $that ) { "int $that" }
multi method that( Str $that ) { "string $that" }
multi method that( $that ) { "something $that" }
};
class Two {
use Multimethod;
multi method that( Int $that ) { "INT $that" }
multi method that( Str $that ) { "STRING $that" }
# Turns out this arbitrary 'isa' hack is really limited -
# putting a typical package name in the signature really
# confuses the parser. Or maybe I am confused.
multi method other( One $one ) { $one->that( 456 ) }
};
my $one = One->new;
my $two = Two->new;
is( $one->this => 'this' );
is( $one->that( 1 ) => 'int 1' );
is( $one->that( 'foo' ) => 'string foo' );
like( $one->that( {} ) => qr/something\ HASH\(/ );
is( $two->that( 1 ) => 'INT 1' );
is( $two->that( 'foo' ) => 'STRING foo' );
like( $two->other( $one ) => 'int 456' );
ok( dies { $two->that( {} ) } );
ok( dies { $two->other( 123 ) } );
ok( dies {
eval '
class Foo {
use Multimethod;
multi method foo( Int $foo ) {};
multi method foo( Int $foo ) {};
}
' || die;
} );
done_testing;
@jbarrett
Copy link
Author

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment