Grammar::Handles, a Raku module for grammar delegation

Handles.rakumod

# Grammar::Handles
my module Grammar::Handles::Helpers {

class X::Grammar::Can'tHandle is Exception {
    has $.type is required;
    multi method CALL-ME(|c) { die self.new(|c)}
    method message { q:to/§err/.trim.indent(2);
      The `handles` grammar trait expects a Grammar, the name
      of a Grammar, a Pair with a Grammar value, or a list of
      any of those types.  But `handles` was called with:
          \qq[{$!type.raku} of type ({$!type.WHAT.raku})]
      §err
}}

class X::Grammar::NotFound is Exception {
    has $.name;
    multi method CALL-ME(|c) { die self.new(|c)}
    method message { qq:to/§err/.trim.indent(2);
      The `handles` grammar trait tried to handle a grammar
      named '$!name' but couldn't find a grammar by that name
      §err
}}

#| A helper select the right error more concisely on the happy path
sub pick-err($_, :$name, |c) {
    when X::TypeCheck::Assignment { X::Grammar::Can'tHandle(:type(.got))  }
    when X::NoSuchSymbol          { X::Grammar::NotFound(:$name) }}

#| Install a method for each known token-name that delegates
#| to the correct Grammar delegee and passes the arguments
#| that the user supplied in their .parse call
my method install-tokens(Mu: :%tokens,
                   :%delegee-args) is export {
    for %tokens.kv -> $name, Grammar $delegee {
        my method TOKEN(:$actions, :$rule='TOP',
                        :$args) is hidden-from-backtrace {
            given %delegee-args{$name} {
                .<actions> = $actions unless .<actions>:exists;
                .<args>    = $args    unless .<args>:exists;
                .<rule>    = $rule    unless .<rule>:exists }
            $delegee.subparse: $.orig, :pos($.to),
                         :from($.from), |%delegee-args{$name}
        }
        self.^add_method: $name, &TOKEN }
}

#| Transforms the &thunk passed to `handles` into a hash
#| where the keys provide token names to install and the
#| values are the delegee Grammars
sub build-token-hash(&thunk --> Map()) is export {
    proto thunk-mapper(| --> Pair)   {*}
    multi thunk-mapper(Grammar $g)   { $g.^name => $g }
    multi thunk-mapper(Str $name) {
        my Grammar $gram = try ::($name);
        $! ?? pick-err($!, :$name)
           !! $name => $gram }
    multi thunk-mapper(Pair (:key($name), :value($_), |)) {
        when Grammar { $name => $_ }
        when Str     { $name => thunk-mapper($_).value }
        default      { #`[type err] thunk-mapper $_ }}
    multi thunk-mapper(Mu $invalid-type) {
        pick-err (try my Grammar $ = $invalid-type) // $! }

    thunk().map: &thunk-mapper
}

#| Overrides the &parse, &subparse, and &parsefile methods with
#| a method that loads %delegee-args with named arguments whose
#| name matches a known $token-name
my method wrap-parse-methods(Mu: :@token-names,
                             :%delegee-args) is export {
    # despite the |, without vv, this sig rejects positionals
    my multi method wrapper ($?, *%args, |)
                             is hidden-from-backtrace {
        for @token-names -> $name {
            next unless %args{$name}:exists;
            if %args{$name}.first({$_ !~~ Map|Pair}, :p) {
                die X::TypeCheck::Binding::Parameter.new:
                        :symbol($name), :expected(Hash()),
                        got => %args{$name} }
            %delegee-args{$name}
              = %args{$name}.Hash;
        }
        nextsame }

    for |<parse subparse parsefile> -> $meth-name {
        self.^add_multi_method: $meth-name, &wrapper }
}

#`[end module Grammar::Handles::Helpers] }

multi trait_mod:<handles>(Mu:U $grammar, &thunk) {
    import Grammar::Handles::Helpers;
    # Ensure we don't mess w/ non-grammar &handles candidates
    when $grammar.HOW
           .get_default_parent_type !=:= Grammar { nextsame }

                     # vvv The name for our new token
    my Grammar %tokens{Str} = build-token-hash &thunk;
    #  ^^^^^^^ the Grammar the token delegates to

    my %delegee-args;
    #  ^^^^^^^^^^^^^ where [sub]?parse[file]? methods save
    #  args for the delegee Grammar (keyed by token name)
    $grammar.&wrap-parse-methods: :%delegee-args,
                                  :token-names(%tokens.keys);
    $grammar.&install-tokens:     :%tokens, :%delegee-args;
}