OneTrueDabe has asked for the wisdom of the Perl Monks concerning the following question:

I admit this example is a bit contrived, but it helps focus on what I'm trying to do...

Say I have a file like:

bang    !some text!
at      @more words@
percent %good stuff%
star    !not in stars!

[download]

I'm trying to match lines where the delimiter is specified by the keyword in the first column.

I can hard-code everything statically, like this:

#!/usr/bin/env perl6
use Test;

our grammar StatGrammar {
    rule TOP {
      [ <bang-line>    | <at-line>    | <hash-line> | <dollar-line>
      | <percent-line> | <caret-line> | <and-line>  | <star-line>   ]
    }

    regex    bang-line { ^    'bang' \s+ '!' (.*?) '!' \n? $ }
    regex      at-line { ^      'at' \s+ '@' (.*?) '@' \n? $ }
    regex    hash-line { ^    'hash' \s+ '#' (.*?) '#' \n? $ }
    regex  dollar-line { ^  'dollar' \s+ '$' (.*?) '$' \n? $ }
    regex percent-line { ^ 'percent' \s+ '%' (.*?) '%' \n? $ }
    regex   caret-line { ^   'caret' \s+ '^' (.*?) '^' \n? $ }
    regex     and-line { ^     'and' \s+ '&' (.*?) '&' \n? $ }
    regex    star-line { ^    'star' \s+ '*' (.*?) '*' \n? $ }
}

our class StatActions {
    method TOP($/) {
      make    $<bang-line>[0] if    $<bang-line>;
      make      $<at-line>[0] if      $<at-line>;
      make    $<hash-line>[0] if    $<hash-line>;
      make  $<dollar-line>[0] if  $<dollar-line>;
      make $<percent-line>[0] if $<percent-line>;
      make   $<caret-line>[0] if   $<caret-line>;
      make     $<and-line>[0] if     $<and-line>;
      make    $<star-line>[0] if    $<star-line>;
    }
}

sub static(Str $str) {
    StatGrammar.parse($str, :actions(StatActions)).made
}

is   static('bang  !one!' ), 'one',  'parse bang!one ok';
isnt static('bang  @one@' ), 'one',  'isnt  bang@one ok';
nok  StatGrammar.parse('bang @one@', :actions(StatActions)), 'nok';

[download]

But that feels kind of gross, and not very DRY...

I can also do this:

#!/usr/bin/env perl6
use Test;

our %sigils = (
    bang    => '!', at      => '@', hash    => '#', dollar  => '$',
    percent => '%', caret   => '^', and     => '&', star    => '*',
);

our grammar DynGrammar {
    regex TOP { ^ (\w+) \s+ (.*?)  \n? $ }
}

our class DynActions {
   method TOP($/) {
      if $1.match( rx/ ^ "{%sigils{$0}}" (.*?) "{%sigils{$0}}" $ / ) -
+> $match {
          make $match[0];
      }
   }
}

sub dyn(Str $str) {
    DynGrammar.parse($str, :actions(DynActions)).made
}

is   dyn('bang    !one!' ), 'one',  'parse bang!one ok';
isnt dyn('bang    @one@' ), 'one',  'isnt  bang@one ok';
nok  DynGrammar.parse('bang @one@', :actions(DynActions)), 'nok';

[download]

Which *ALMOST* works... Except that the mismatch, erm, "fails to fail".

Can anybody think of a way to either A: 'fail' a match from within an action, or B: move my pattern matching up into the grammar itself? (or C: tell me I'm going about it all wrong, and suggest a better way, hehe!)

Cheers! :-D

Replies are listed 'Best First'.
Re: Perl6: Dynamic Grammars
by OneTrueDabe (Acolyte) on Jun 01, 2016 at 14:43 UTC

    What's that old adage...? "Ask and ye shall figure it out yourself." :-D

    #!/usr/bin/env perl6
use Test;

our %sigils = (
    bang   => '!', at      => '@', hash  => '#',
    dollar => '$', percent => '%', caret => '^',
    and    => '&', star    => '*', zero  => '0',
);

our grammar DynGrammar {
    my $sigil;
    regex TOP {
      ^^ (\w+) <?{ $sigil=%sigils{$0} if %sigils{$0}:exists }>
         \s+ $sigil (.*?) $sigil \n?  $$ }
}

our class DynActions {
    method TOP($/) { make $1 }
}

sub dyn(Str $str) {
    DynGrammar.parse($str, :actions(DynActions)).made
}

is   dyn('bang    !one!' ), 'one',  'parse bang!one ok';
is   dyn('zero    0one0' ), 'one',  'parse zero0one ok';
isnt dyn('bang    @one@' ), 'one',  'isnt  bang@one ok';
isnt dyn('BONK    !one!' ), 'one',  'isnt  BONK!one ok';
nok  DynGrammar.parse('bang @one@', :actions(DynActions)), 'nok';
nok  DynGrammar.parse('BONK !one!', :actions(DynActions)), 'unk';

    [download]

    The missing piece was to use a Block (in this case, a <?{condition}> assertion) to save off the capture. (I had initially broken out the assignment from the condition, just in case the expression looked Falsey, but thanks to Perl 6, "0" is True! Hallelujah!)

    It still might not be the most idiomatic, I don't know; I'm always open to suggestions...

[reply]
[d/l]
[select]
[reply]
        Another option would be to use meta programming, e.g. starting with 
        grammar g {
    rule TOP { <bang> | <at> }
    rule bang { 'bang' '!' [<-[!]>*] '!' }
}

g.^add_method('at', rx { 'at' [\s*]  '@' [<-[@]>*] '@' } );
# ... then do the above for each of the sigils
g.^compose;

say g.parse('bang !some text!');
say g.parse('at @some text@');

        [download]
[reply]
[d/l]
      A tweaked and simplified version: 
      my %sigils =
    bang   => '!', at      => '@', hash  => '#',
    dollar => '$', percent => '%', caret => '^',
    and    => '&', star    => '*', zero  => '0';

my regex line {
    ^^ :my $s; (\w+) <?{ $s = %sigils{$0} }> \h+ $s (\N*) $s $$
}

.say for "star *foo*\nat @bar\nat @baz@" ~~ m:g/<line>/;

      [download]
[reply]
[d/l]
        my regex line {
    ^^ :my $s; (\w+) <?{ $s = %sigils{$0} }> \h+ $s (\N*) $s $$
}

.say for "star *foo*\nat @bar\nat @baz@" ~~ m:g/<line>/;

        That's HOT! :-D

        But how would I rewrite my tests, then — which actually want to operate on the captured value?

        This seems clunky and naïve: (Not unlike myself... «grin»)

        #!/usr/bin/env perl6
use Test;

my %sigils =
    bang   => '!', at      => '@', hash  => '#',
    dollar => '$', percent => '%', caret => '^',
    and    => '&', star    => '*', zero  => '0';

my regex line {
    ^^ :my $s; (\w+) <?{ $s = %sigils{$0} }> \h+ $s (\N*) $s $$
}

is  ('bang !one!' ~~ m/<line>/)<line>[1],     'one', 'is   bang!one';
is  ('zero 0one0' ~~ m/<line>/)<line>[1],     'one', 'is   zero0one';
isnt 'bang @one@' ~~ m/<line>/ && $<line>[1], 'one', 'isnt bang@one';
isnt 'BONK !one!' ~~ m/<line>/ && $<line>[1], 'one', 'isnt BONK!one';
nok  'bang @one@' ~~ m/<line>/, 'mismatch fails';
nok  'BONK !one!' ~~ m/<line>/, 'unknown fails';

        [download]
[reply]
[d/l]

Back to Seekers of Perl Wisdom