# pX/Common/iterator_engine.pl - fglock

#



use strict;

use warnings;

#use Smart::Comments; for debugging, look also at Filtered-Comments.pm



=pod



A "rule" function gets as argument a list:



0 - a string to match

1 - an optional "continuation"

2 - an optional "flags" hashref

    'capture'=>1 means 'return whatever matches'



it returns (or "yields"):



    undef - match failed



or a hash containing:



    state - a "continuation" or undef

    bool - an "assertion" (true/false)

    match - the "match" tree or undef

    tail - the string tail or undef

    capture - the tree of captured things

    abort - the match was stopped by a { return } or a fail(),

           and it should not backtrack or whatever



Continuations are used for backtracking.



A "ruleop" function gets some arguments and returns a "rule".



=cut



# XXX - optimization - pass the string index around, 

# XXX   instead of copying the whole string to $tail every time



# XXX - weaken self-referential things



sub ruleop::alternation {

    # alternation is first match (not longest).  though we need a 

    # separate longest match for tokens (putter on #perl6)

    # update: <%var> does longest match based on the keys length() (TimToady on #perl6)



    # note: the list in @$nodes can be modified at runtime



    my $nodes = shift;

    # die "alternation list is empty" unless ref($nodes) eq 'ARRAY' && @$nodes;

    return sub {

        ### testing alternations on : @_, $nodes

        return unless @$nodes;



        my $tail =  $_[0];

        my $state = $_[1] ? [ @{$_[1]} ] : [ 0, 0 ];

        my $flags = $_[2];

        my $match;

        while ( defined $state ) {

            ### alternation string to match: "$tail - (node,state)=@$state"

            $match = 

                $nodes->[ $state->[0] ]->( $tail, $state->[1], $flags );

            ### match: $match

            if ( $match->{state} ) {

                $state->[1] = $match->{state};

            }

            else

            {

                $state->[0]++;

                $state->[1] = 0;

                ### next alternation state - (node,state):@$state

                $state = undef if $state->[0] > $#$nodes;

            }

            $match->{state} = $state;

            return $match if $match->{bool} || $match->{abort};

        }

        return;

    }

}



sub ruleop::concat {

    

    # note: the list in @nodes can NOT be modified at runtime

    # update: this is ok, because we can use <$var><$var> instead

    

    return ruleop::concat( +shift, ruleop::concat( @_ ) )

        if @_ > 2;

    my @nodes = @_;

    return sub {

        my $tail  = $_[0];

        my @state = $_[1] ? ( @{$_[1]} ) : ( 0, 0 );

        my $flags = $_[2];

        my @matches;

        while (1) {

            

            $matches[0] = $nodes[0]->( $tail, $state[0], $flags );

            ### 1st match: $matches[0]

            return $matches[0] 

                if $matches[0]{abort};

            if ( ! $matches[0]{bool} ) {

                return unless defined $matches[0]{state};

                @state = ( $matches[0]{state}, 0 );

                next;

            }

            

            $matches[1] = $nodes[1]->( $matches[0]{tail}, $state[1], $flags );

            ### 2nd match: $matches[1]

            return $matches[1] 

                if $matches[1]{abort};

            if ( ! $matches[1]{bool} ) {

                if ( ! defined( $matches[1]{state} ) ) {

                    return unless defined $matches[0]{state};

                    @state = ( $matches[0]{state}, 0 );

                }

                ### backtracking - state: @state

                ### backtracking - match: @matches

                next;

            }

            

            my $succ;

            if ( ! defined( $matches[1]{state} ) ) {

                $succ = [ $matches[0]{state}, 0 ] if defined $matches[0]{state};

            }

            else {

                $succ = [ $state[0], $matches[1]{state} ];

            }



            my $capture = [];

            ### capture: $matches[0]{capture},$matches[1]{capture}

            $capture = $matches[0]{capture} 

                if $matches[0]{capture};

            push @$capture, @{$matches[1]{capture}} 

                if $matches[1]{capture};

            undef $capture unless @$capture;



            return { 

                bool =>  1,

                match => [ @matches ], 

                tail =>  $matches[1]{tail},

                state => $succ,

                capture => $capture,

            };

        }

    }

}



sub ruleop::constant { 

    my $const = shift;

    return sub {

        ### matching constant:$_[0],$const

        return if ! $_[0] || $_[0] !~ m/^(\Q$const\E)(.*)/s;

        return { bool => 1,

                 match => { constant => $1 }, 

                 capture => [ $1 ], 

                 tail => $2,

               }

           if $_[2]{capture};  # flags->{capture}

        return { bool => 1,

                 match => { constant => $1 }, 

                 tail => $2,

               }

    }

}



sub ruleop::null {

    return sub {

        return { bool => 1,

                 match => 'null',

                 ( $_[2]->{capture} ? ( capture => [ '' ] ) : () ),

                 tail => $_[0],

               }

    }

};



sub ruleop::capture {

    # sets the 'capture' flag and return a labeled capture

    # XXX - generalize to: set_flag('capture',1)

    my $label = shift;

    my $node = shift;

    sub {

        my @param = @_;

        $param[2] = {} unless defined $param[2];

        $param[2] = { %{$param[2]}, capture=>1 };

        my $match = $node->( @param );

        return unless $match->{bool};

        return if $match->{abort};

        my $new_match = { %$match };

        $new_match->{capture} = [ { $label => $match->{capture} } ];

        return $new_match;

    }

}



=for capture

At runtime, this must return _only_ the capture set inside capture_closure:

  xx(xx(xx(

    capture_closure(..)

  )))

One way to do it is to post-process the match:

  try(

    xx(xx(xx(

      abort(

        capture_closure(..)

      )

    )))

  )

abort() sets a 'rule_finished' flag in the returned match, 

that makes it return until the start of the rule, which unsets the flag before returning.

- this can also be used to do fail() and assert(), and 'no-backtracking checkpoints'

=cut



# experimental!

sub ruleop::try { 

    my $op = shift;

    return sub {

        my $match = $op->( @_ );

        ### abortable match...

        $match->{abort} = 0;

        return $match;

    };

};



# experimental!

sub ruleop::abort { 

    my $op = shift;

    return sub {

        my $match = $op->( @_ );

        ### aborting match: $match

        $match->{abort} = 1;

        return $match;

    };

};



# experimental!

sub ruleop::negate { 

    my $op = shift;

    return sub {

        my $tail = $_[0];

        my $match = $op->( @_ );

        return if $match->{bool};

        return { bool => 1,

                 match => 'null',

                 tail => $tail,

               }

    };

};



# experimental!

=for example

    # adds an 'before' or 'after' sub call, which may print a debug message 

    ruleop::wrap( { 

            before => sub { print "matching variable: $_[0]\n" },

            after  => sub { $_[0]->{bool} ? print "matched\n" : print "no match\n" },

        },

        \&variable

    )

=cut

sub ruleop::wrap {

    my $debug = shift;

    my $node = shift;

    sub {

        $debug->{before}( @_ ) if $debug->{before};

        my $match = $node->( @_ );

        $debug->{after}( $match, @_ ) if $debug->{after};

        return $match;

    }

}



# ------- higher-order ruleops



sub ruleop::optional {

    return ruleop::alternation( [ $_[0], ruleop::null() ] );

}



sub ruleop::null_or_optional {

    return ruleop::alternation( [ ruleop::null(), $_[0] ] );

}



sub ruleop::greedy_plus { 

    my $node = shift;

    my $alt;

    $alt = ruleop::concat( 

        $node, 

        ruleop::optional( sub{ goto $alt } ),  

    );

    return $alt;

}



sub ruleop::greedy_star { 

    my $node = shift;

    return ruleop::optional( ruleop::greedy_plus( $node ) );

}



sub ruleop::non_greedy_star { 

    my $node = shift;

    ruleop::alternation( [ 

        ruleop::null(),

        ruleop::non_greedy_plus( $node ) 

    ] );

}



sub ruleop::non_greedy_plus { 

    my $node = shift;



    # XXX - needs optimization for faster backtracking, less stack usage



    return sub {

        my $tail =  $_[0];

        my $state = $_[1] || { state => undef, op => $node };

        my $flags = $_[2];



        # XXX - didn't work

        # my $match = $state->{op}->( $tail, $state->{state}, $flags ); 



        my $match = $state->{op}->( $tail, undef, $flags );

        return unless $match->{bool};

        $match->{state} = {

            state => $match->{state},

            op    => ruleop::concat( $node, $state->{op} ),

        };

        return $match;

    }

}



1;

