File Coverage

support/SigParse.yp

Criterion	Covered	Total	%
statement	89	96	92.7
branch	31	36	86.1
condition	7	7	100.0
subroutine	17	18	94.4
pod	1	2	50.0
total	145	159	91.1

# SigParse.yp: Parse::Yapp input to parse signatures in Sub::Multi::Tiny

#############################################################################
# Header

%{

# Imports {{{1

use 5.006;
use strict;
use warnings;

use Text::Balanced qw(extract_codeblock);

# Types of constraints we've seen - bit offsets
use enum
    # Flags set by the parser
    'SEEN_WHERE',       # `where` clause
    'SEEN_TYPE',        # Type constraint
    'SEEN_POS',         # Positional argument
    'SEEN_NAMED',       # Named argument
    # future: SEEN_LITERAL for signatures holding literal values
    # instead of name matches.

    # Flags set by later processing
    'HAS_MULTIPLE_ARITIES',     # Set if there are at least two
                                # different positional arities in a
                                # set of impls
;

# Set bits in YYData->{SEEN}
    vec($_[0]->YYData->{SEEN}, $_[$_], 1) = 1 foreach 1..$#_;
}

# }}}1
# Documentation {{{1

=head1 NAME

Sub::Multi::Tiny::SigParse - Parse::Yapp input to parse signatures in Sub::Multi::Tiny

=head1 SYNOPSIS

Generate the .pm file:

    yapp -m Sub::Multi::Tiny::SigParse -o lib/Sub/Multi/Tiny/SigParse.pm support/SigParse.yp

And then:

    use Sub::Multi::Tiny::SigParse;
    my $ast = Sub::Multi::Tiny::SigParse::Parse($signature);

=head1 FUNCTIONS

=cut

# }}}1

%}

#############################################################################
# Token and precedence definitions

# TODO: slurpies (prefix *, +); trailing ?, !

# Separator (usually a comma)
%token SEPAR

# Type before a variable name
%token TYPE

# Parameter, named or positional
%token PARAM

# "where BLOCK"
%token WHERE

%%

#############################################################################
# Rules

signature:
                                            { [] }  # always return arrayref
    |   parameter                           { [ $_[1] ] }
    |   parameter SEPAR signature           { [ $_[1], @{$_[3]} ] }
    # Permit trailing comma
    |   parameter SEPAR signature SEPAR     { [ $_[1], @{$_[3]} ] }
    ;

parameter:
        PARAM
        {
            _seen $_[0], $_[1]->{named} ? SEEN_NAMED : SEEN_POS;
            return $_[1];
        }

    |   PARAM WHERE
        {
            _seen $_[0], $_[1]->{named} ? SEEN_NAMED : SEEN_POS;
            _seen $_[0], SEEN_WHERE;
            return +{%{$_[1]}, where=>$_[2]};
        }

    |   TYPE PARAM
        {
            _seen $_[0], $_[2]->{named} ? SEEN_NAMED : SEEN_POS;
            _seen $_[0], SEEN_TYPE;
            return +{%{$_[2]}, type => $_[1]};
        }

    |   TYPE PARAM WHERE
        {
            _seen $_[0], $_[2]->{named} ? SEEN_NAMED : SEEN_POS;
            _seen $_[0], SEEN_TYPE, SEEN_WHERE;
            return +{%{$_[2]}, where=>$_[3], type => $_[1]}
        }
    ;

%%

#############################################################################
# Footer

# Tokenizer and error-reporting routine for Parse::Yapp {{{1

# The lexer
    my $parser = shift;
    my $text = $parser->YYData->{TEXT};

    $$text =~ m/\G\s+/gc;    # Skip H and V whitespace
    $parser->YYData->{CURR_TOK_POS} = pos($$text);

    return ('', undef) unless (pos($$text)||0) < length($$text);    # EOF

    $$text =~ m/\G,/gc and return (SEPAR => 0); # 0 is a dummy value

    if($$text =~ m/\G([:]?)([\$\@\%\&\*]\w+)\b([?!]?)/gc) {
        my $retval = {};
        $retval->{name} = $2;
        $retval->{named} = !!$1;
        $retval->{reqd} = (
            ($retval->{named} && $3 eq '!') ||  # Named: optional unless !
            (!$retval->{named} && $3 ne '?')    # Positional: reqd unless ?
        );
        return (PARAM => $retval);
    }

    if($$text =~ m/\Gwhere\s*\{/gci) {
        pos($$text) -= 1;    # Get the lbrace back
        my ($block) = extract_codeblock($$text);     # Updates pos()
        return (WHERE => $block) if defined $block;
        die "Saw a 'where' without a valid block after it";
    }

    # Permit braced expressions for complex type checks
    if($$text =~ m/\G\{/gc) {
        pos($$text) -= 1;    # Get the lbrace back
        my ($block) = extract_codeblock($$text);     # Updates pos()
        return (TYPE => $block) if defined $block;
        die "Saw an opening brace without a valid block after it";
    }

    # If the next thing is a backslash, die --- prohibit backslash to start
    # a typecheck as a guard against '' vs "" confusion.  If you want a
    # backslash, use the {} form.
    if($$text =~ m{\G\\}gc) {
        die "Saw a backslash where I don't know what to do with it!  ('' vs \"\" confusion?)";
    }

    # Otherwise, assume a single word is a typecheck
    $$text =~ m/\G(\S+)/gc and return (TYPE => $1);

    die "This should never happen!  Unlexable text was: " .
        substr($$text, pos($$text));
} #_next_token()

# Report an error
    my $parser = shift;
    my $startpos = $parser->YYData->{CURR_TOK_POS};
    my $endpos = pos(${ $parser->YYData->{TEXT} });
    my $got = $parser->YYCurtok || '<end of input>';
    my $val='';
    $val = ' (' . $parser->YYCurval . ')' if $parser->YYCurval;

    my $errmsg  = 'Syntax error: could not understand ' . $got . $val .
                    " at positions $startpos..$endpos";
    if(ref($parser->YYExpect) eq 'ARRAY') {
        $errmsg .= ".\nExpected one of: " . join(',', @{$parser->YYExpect});
    } else {
        $errmsg .= ':'
    }

    # Print the text and flag the error
    my $copy = ${ $parser->YYData->{TEXT} };
    $copy =~ s/\s/ /g;  # Normalize spaces so pos values line up
    $errmsg .= "\n$copy";
    $errmsg .= "\n" . (' ' x $startpos) . ('^' x ($endpos-$startpos));

    $errmsg .= "\n";    # No stack trace
    die $errmsg;
} #_report_error()

# }}}1
# Top-level parse function {{{1

=head2 Parse

Parse arguments.  Usage:

    my $ast = Sub::Multi::Tiny::SigParse::Parse($signature);

=cut

    my $text = shift;
    unless(defined $text) {
        require Carp;
        Carp::croak 'Parse: Need a signature to parse';
    }

    my $parser = __PACKAGE__->new;
    my $hrData = $parser->YYData;

    # Data we use while parsing.

    # TEXT: The input text.  Store it as a reference so pos() will
    # be preserved across calls to _next_token.
    $hrData->{TEXT} = \"$text";

    # CURR_TOK_POS: the pos() value where the current token started.
    # Used in reporting errors.
    $hrData->{CURR_TOK_POS} = -1;

    # SEEN: bit flags for which types of things we've seen
    $hrData->{SEEN} = '';

    my $lrParms = $parser->YYParse(yylex => \&_next_token,
        yyerror => \&_report_error,
        (@_ ? (yydebug => $_[0]) : ()),
    );
    my %retval = (seen => $hrData->{SEEN}, parms => $lrParms);

    return \%retval;
} #Parse()

# }}}1
# Rest of the docs {{{1

=head1 AUTHOR

Chris White E<lt>[e-mail]<gt>

=head1 LICENSE

Copyright (C) 2019 Chris White E<lt>[e-mail]<gt>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

# }}}1

# vi: set fdm=marker: #