Example for "DSL's made even simpler" blog post

gistfile1.pl

#!perl
# Copyright 2012 Jeffrey Kegler
# This file is part of Marpa::R2.  Marpa::R2 is free software: you can
# redistribute it and/or modify it under the terms of the GNU Lesser
# General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# Marpa::R2 is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser
# General Public License along with Marpa::R2.  If not, see
# http://www.gnu.org/licenses/.

# Demo of scannerless parsing -- a calculator DSL

use 5.010;
use strict;
use warnings;
use English qw( -no_match_vars );
use Getopt::Long;

use Marpa::R2 2.040000;

sub usage {

    die <<"END_OF_USAGE_MESSAGE";
    $PROGRAM_NAME
    $PROGRAM_NAME --stdin < file
With --stdin arg, reads expression from standard input.
By default, runs a test.
END_OF_USAGE_MESSAGE
} ## end sub usage

my $stdin_flag = 0;
my $getopt_result = Getopt::Long::GetOptions( 'stdin!' => \$stdin_flag, );
usage() if not $getopt_result;

my $input;
if ($stdin_flag) {
    $input = do { local $INPUT_RECORD_SEPARATOR = undef; <> };
}

my $rules = <<'END_OF_GRAMMAR';
:start ::= script
script ::= expression
script ::= script ';' expression action => do_arg2
<reduce op> ::= '+' | '-' | '/' | '*'
expression ::=
     number
   | variable action => do_is_var
   | '(' expression ')' assoc => group action => do_arg1
  || '-' expression action => do_negate
  || expression '^' expression action => do_caret assoc => right
  || expression '*' expression action => do_star
   | expression '/' expression action => do_slash
  || expression '+' expression action => do_plus
   | expression '-' expression action => do_minus
  || expression ',' expression action => do_array
  || <reduce op> 'reduce' expression action => do_reduce
  || variable '=' expression action => do_set_var

number ~ [\d]+
variable ~ [\w]+
:discard ~ whitespace
whitespace ~ [\s]+
# allow comments
:discard ~ <hash comment>
<hash comment> ~ <terminated hash comment> | <unterminated
   final hash comment>
<terminated hash comment> ~ '#' <hash comment body> <vertical space char>
<unterminated final hash comment> ~ '#' <hash comment body>
<hash comment body> ~ <hash comment char>*
<vertical space char> ~ [\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}]
<hash comment char> ~ [^\x{A}\x{B}\x{C}\x{D}\x{2028}\x{2029}]
END_OF_GRAMMAR

my $grammar = Marpa::R2::Scanless::G->new(
    {   action_object  => 'My_Actions',
        default_action => 'do_arg0',
        source         => \$rules,
    }
);

sub calculate {
    my ($p_string) = @_;

    my $recce = Marpa::R2::Scanless::R->new( { grammar => $grammar } );

    my $self = bless { grammar => $grammar }, 'My_Actions';
    $self->{recce}        = $recce;
    $self->{symbol_table} = {};
    local $My_Actions::SELF = $self;

    if ( not defined eval { $recce->read($p_string); 1 } ) {

        # Add last expression found, and rethrow
        my $eval_error = $EVAL_ERROR;
        chomp $eval_error;
        die $self->show_last_expression(), "\n", $eval_error, "\n";
    } ## end if ( not defined eval { $recce->read($p_string); 1 })
    my $value_ref = $recce->value();
    if ( not defined $value_ref ) {
        die $self->show_last_expression(), "\n",
            "No parse was found, after reading the entire input\n";
    }
    return ${$value_ref}, $self->{symbol_table};

} ## end sub calculate

sub report_calculation {
    my ($string) = @_;
    my ( $result, $symbol_table ) = calculate( \$string );
    $result = join q{,}, @{$result} if ref $result eq 'ARRAY';
    my $output = "result = $result\n";
    for my $symbol ( sort keys %{$symbol_table} ) {
        $output .= qq{value of "$symbol" = "}
            . $symbol_table->{$symbol} . qq{"\n};
    }
    chomp $output;
    return $output;
} ## end sub report_calculation

if ($stdin_flag) {
    my $actual_value = report_calculation($input);
    if ( !defined $actual_value ) {
        die 'NO PARSE!';
    }
    say $actual_value;
    exit 0;
} ## end if ($stdin_flag)

my @tests_data = (
    [ "4 * 3 + 42 / 1" => 'result = 54' ],
    [   "4 * 3 / (a = b = 5) + 42 - 1" =>
            qq{result = 43.4\nvalue of "a" = "5"\nvalue of "b" = "5"}
    ],
    [ "4 * 3 /  5 - - - 3 + 42 - 1" => 'result = 40.4' ],
    [   "a=1;b = 5;  - a - b" =>
            qq{result = -6\nvalue of "a" = "1"\nvalue of "b" = "5"}
    ],
    [ "1 * 2 + 3 * 4 ^ 2 ^ 2 ^ 2 * 42 + 1" => 'result = 541165879299' ],
    [ "+ reduce 1 + 2, 3,4*2 , 5"          => 'result = 19' ]
);

my $failed_tests = 0;
for my $test_data (@tests_data) {
    my ( $test_string, $expected_value ) = @{$test_data};
    my $actual_value = report_calculation($test_string);
    say '-' x 40;
    say qq{Input: "$test_string"};
    say $actual_value;
    if ( $actual_value ne $expected_value ) {
        say qq{   FAIL: Value should be: "$expected_value"\n};
        $failed_tests++;
    }
} ## end for my $test_data (@tests_data)
die "$failed_tests TESTS FAILED!" if $failed_tests;

package My_Actions;
our $SELF;
sub new { return $SELF }

sub do_is_var {
    my ( $self, $var ) = @_;
    my $value = $self->{symbol_table}->{$var};
    Marpa::R2::Context::bail(qq{Undefined variable "$var"})
        if not defined $value;
    return $value;
} ## end sub do_is_var

sub do_set_var {
    my ( $self, $var, undef, $value ) = @_;
    return $self->{symbol_table}->{$var} = $value;
}

sub do_negate {
    return -$_[2];
}

sub do_arg0 { return $_[1]; }
sub do_arg1 { return $_[2]; }
sub do_arg2 { return $_[3]; }

sub do_array {
    my ( undef, $left, undef, $right ) = @_;
    my @value = ();
    my $ref;
    if ( $ref = ref $left ) {
        Marpa::R2::Context::bail("Bad ref type for array operand: $ref")
            if $ref ne 'ARRAY';
        push @value, @{$left};
    }
    else {
        push @value, $left;
    }
    if ( $ref = ref $right ) {
        Marpa::R2::Context::bail("Bad ref type for array operand: $ref")
            if $ref ne 'ARRAY';
        push @value, @{$right};
    }
    else {
        push @value, $right;
    }
    return \@value;
} ## end sub do_array

our %BINOP_CLOSURE;

BEGIN {
    %BINOP_CLOSURE = (
        '*' => sub { $_[0] * $_[1] },
        '/' => sub {
            Marpa::R2::Context::bail('Division by zero') if not $_[1];
            $_[0] / $_[1];
        },
        '+' => sub { $_[0] + $_[1] },
        '-' => sub { $_[0] - $_[1] },
        '^' => sub { $_[0]**$_[1] },
    );
} ## end BEGIN

sub do_binop {
    my ( $op, $left, $right ) = @_;
    my $closure = $BINOP_CLOSURE{$op};
    Marpa::R2::Context::bail(
        qq{Do not know how to perform binary operation "$op"})
        if not defined $closure;
    return $closure->( $left, $right );
} ## end sub do_binop

sub do_caret {
    my ( undef, $left, undef, $right ) = @_;
    return do_binop( '^', $left, $right );
}

sub do_star {
    my ( undef, $left, undef, $right ) = @_;
    return do_binop( '*', $left, $right );
}

sub do_slash {
    my ( undef, $left, undef, $right ) = @_;
    return do_binop( '/', $left, $right );
}

sub do_plus {
    my ( undef, $left, undef, $right ) = @_;
    return do_binop( '+', $left, $right );
}

sub do_minus {
    my ( undef, $left, undef, $right ) = @_;
    return do_binop( '-', $left, $right );
}

sub do_reduce {
    my ( undef, $op, undef, $args ) = @_;
    my $closure = $BINOP_CLOSURE{$op};
    Marpa::R2::Context::bail(
        qq{Do not know how to perform binary operation "$op"})
        if not defined $closure;
    $args = [$args] if ref $args eq '';
    my @stack = @{$args};
    OP: while (1) {
        return $stack[0] if scalar @stack <= 1;
        my $result = $closure->( $stack[-2], $stack[-1] );
        splice @stack, -2, 2, $result;
    }
    Marpa::R2::Context::bail('Should not get here');
} ## end sub do_reduce

sub show_last_expression {
    my ($self) = @_;
    my $recce = $self->{recce};
    my ( $start, $end ) = $recce->last_completed_range('expression');
    return 'No expression was successfully parsed' if not defined $start;
    my $last_expression = $recce->range_to_string( $start, $end );
    return "Last expression successfully parsed was: $last_expression";
} ## end sub show_last_expression

# vim: expandtab shiftwidth=4: