view release on metacpan or  search on metacpan

lib/Dallycot/Parser.pm  view on Meta::CPAN

package Dallycot::Parser;
our $AUTHORITY = 'cpan:JSMITH';

# ABSTRACT: Parse Dallycot source into an abstract syntax tree

use strict;
use warnings;

use utf8;
use experimental qw(switch);

use Marpa::R2;
use Math::BigRat;

use Dallycot::Value::String;
use Dallycot::Value::URI;

use Scalar::Util qw(blessed);
use String::Escape qw(unbackslash unquote);

use Dallycot::AST::Sequence;
use Dallycot::AST::Apply;
use Dallycot::Value::URI;

my $grammar = Marpa::R2::Scanless::G->new(
  { action_object  => __PACKAGE__,
    bless_package  => 'Dallycot::AST',
    default_action => 'copy_arg0',
    source         => do { local ($/) = undef; my $s = <DATA>; \$s; }
  }
);

sub new {
  my ($class) = @_;

  $class = ref($class) || $class;
  return bless {} => $class;
}

sub grammar { return $grammar; }

sub wants_more {
  my ( $self, $val ) = @_;

  if ( @_ == 2 ) {
    $self->{wants_more} = $val;
  }
  return $self->{wants_more};
}

sub error {
  my ( $self, $val ) = @_;

  if ( @_ == 2 ) {
    $self->{error} = $val;
  }
  return $self->{error};
}

sub warnings {
  my ( $self, $warnings ) = @_;

  if ( @_ == 2 ) {
    $self->{warnings} = $warnings;
  }
  if (wantarray) {
    return @{ $self->{warnings} };
  }
  else {
    return @{ $self->{warnings} } != 0;
  }
}

sub parse {
  my ( $self, $input ) = @_;

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

  $self->error(undef);
  $self->warnings( [] );

  my $worked = eval {
    $re->read( \$input );
    1;
  };
  if ($@) {
    $@ =~ s{Marpa::R2\s+exception\s+at.*$}{}xs;
    $self->error($@);
    return;
  }
  elsif ( !$worked ) {
    $self->error("Unable to parse.");
    return;
  }
  my $parse = $re->value;
  my $result;

lib/Dallycot/Parser.pm  view on Meta::CPAN

  return bless $constants => 'Dallycot::Value::Vector';
}

sub empty_set {
  return bless [] => 'Dallycot::Value::Set';
}

sub build_set {
  my ( undef, $expressions ) = @_;

  my @expressions = map { flatten_union($_) } @$expressions;

  return bless \@expressions => 'Dallycot::AST::BuildSet';
}

sub flatten_union {
  my ($thing) = @_;

  if ( $thing->isa('Dallycot::AST::Union') ) {
    return @$thing;
  }
  else {
    return $thing;
  }
}

sub stream_constant {
  my ( undef, $constants ) = @_;

  if (@$constants) {
    my $result = bless [ pop @$constants, undef ] => 'Dallycot::Value::Stream';
    while (@$constants) {
      $result = bless [ pop @$constants, $result ] => 'Dallycot::Value::Stream';
    }
    return $result;
  }
  else {
    return bless [] => 'Dallycot::Value::EmptyStream';
  }
}

sub _flatten_binary {
  my ( undef, $class, $left_value, $right_value ) = @_;

  if ( ref $left_value eq $class ) {
    if ( $right_value eq $class ) {
      push @{$left_value}, @{$right_value};
      return $left_value;
    }
    else {
      push @{$left_value}, $right_value;
      return $left_value;
    }
  }
  elsif ( ref $right_value eq $class ) {
    unshift @$right_value, $left_value;
    return $right_value;
  }
  else {
    return bless [ $left_value, $right_value ] => $class;
  }
}

sub zip {
  my ( undef, $left_value, $right_value ) = @_;

  return _flatten_binary( undef, 'Dallycot::AST::Zip', $left_value, $right_value );
}

sub set_union {
  my ( undef, $left_value, $right_value ) = @_;

  return _flatten_binary( undef, 'Dallycot::AST::Union', $left_value, $right_value );
}

sub set_intersection {
  my ( undef, $left_value, $right_value ) = @_;

  return _flatten_binary( undef, 'Dallycot::AST::Intersection', $left_value, $right_value );
}

sub vector_index {
  my ( undef, $vector, $index ) = @_;

  if ( ref $vector eq 'Dallycot::AST::Index' ) {
    push @{$vector}, $index;
    return $vector;
  }
  else {
    return bless [ $vector, $index ] => 'Dallycot::AST::Index';
  }
}

sub vector_push {
  my ( undef, $vector, $scalar ) = @_;

  if ( $vector->[0] eq 'Push' ) {
    push @{$vector}, $scalar;
    return $vector;
  }
  else {
    return [ Push => ( $vector, $scalar ) ];
  }
}

sub defined_q {
  my ( undef, $expression ) = @_;

  return bless [$expression] => 'Dallycot::AST::Defined';
}

##
# Eventually, Range will be a type representing all values between
# two endpoints.
#
# Q: how to indicate open/closed endpoints
#
# ( e1 .. e2 )
# [ e1 .. e2 )
# ( e1 .. e2 ]