package Regex::Ops::Tree;
use base 'Exporter';
use strict;
use Carp qw(confess);

@Regex::Ops::Tree::EXPORT = qw(rop);

# Tree operators
#
# This package defines operators that can be used to construct a
# syntax tree for a regular expression.
#

# Core ops generated by parser
# ----------------------------
# match : Match a single codepoint
# charclass : Match a character class
# seq
# alternate : Match R or S at the same point?
# multi_match : Match m..n repetitions of R
# group : Capture a group
# scan : Scan through input until R matches
# atend : At the end of the input?
# advance : Unconditionally advance 1 char

# Stuff that is used for optimization
# -----------------------------------
# nop : Do nothing (placeholder)
# check : Check to be sure we are n chars away from the end of the string

@Regex::Ops::Tree::_atom::ISA        = qw(Regex::Ops::Tree);
@Regex::Ops::Tree::_onearg::ISA      = qw(Regex::Ops::Tree);

@Regex::Ops::Tree::match::ISA        = qw(Regex::Ops::Tree::_atom);
@Regex::Ops::Tree::charclass::ISA   = qw(Regex::Ops::Tree::_atom);
@Regex::Ops::Tree::seq::ISA          = qw(Regex::Ops::Tree);
@Regex::Ops::Tree::alternate::ISA    = qw(Regex::Ops::Tree);
@Regex::Ops::Tree::multi_match::ISA  = qw(Regex::Ops::Tree);
@Regex::Ops::Tree::group::ISA        = qw(Regex::Ops::Tree::_onearg);
@Regex::Ops::Tree::scan::ISA         = qw(Regex::Ops::Tree::_onearg);
@Regex::Ops::Tree::atend::ISA        = qw(Regex::Ops::Tree);
@Regex::Ops::Tree::advance::ISA      = qw(Regex::Ops::Tree::_atom);

@Regex::Ops::Tree::nop::ISA          = qw(Regex::Ops::Tree);
@Regex::Ops::Tree::check::ISA        = qw(Regex::Ops::Tree);

@Regex::Ops::Tree::call::ISA         = qw(Regex::Ops::Tree);

# Construct a new op
sub op {
    my ($class, $name, $args, %opts) = @_;

    $class = ref($class) if ref $class;
    while (1) {
        last if UNIVERSAL::isa("${class}::$name", 'Regex::Ops::Tree');
        $class =~ s/::\w+$// or die "Called op on invalid class $_[0]";
    }
    $class = "${class}::$name";
    my $self = bless { name => $name,
                       args => $args || [],
                       %opts }, $class;

    return $self->init();
}

# Default initialization, to be overridden in subclasses.
sub init { return shift(); };

# Exportable convenience function
sub rop {
    return __PACKAGE__->op(@_);
}

use vars qw(%MARKERS);
sub mark {
    my $name = shift || '';
    my $number = ++$MARKERS{$name};
    $number = '' if ($number == 1) && ($name ne '');
    return bless([ 'label', "\@$name$number" ], 'asm_op');
}

############################################################################
# OPTIMIZATION INFORMATION
#
# All of this is only for computing information that may be useful in
# optimizing generated regular expressions. It is not needed for basic
# compilation.
#
# Probably the best way to understand this stuff is to look at
# where it's used, mostly in PreOptimize.pm.
############################################################################

sub order_startset {
    my $start = shift;

    # Must maintain invariant that '' comes first, if it exists.
    my @null;
    push(@null, '') if exists $start->{''};
    delete $start->{''};
    return (@null, keys %$start);
}

# Defaults
sub minlen { confess "unimplemented" }
sub maxlen { confess "unimplemented" }
sub startset { confess "unimplemented" }
sub hasback { 0 }
sub dfa_safe { 0 }

# Superclass for ops like scan(R) that contain a single subexpression.
# By default, all calls are propagated to the subexpression.
package Regex::Ops::Tree::_onearg;
sub minlen { my ($op) = @_; $op->{args}->[0]->minlen() }
sub maxlen { my ($op) = @_; $op->{args}->[0]->maxlen() }
sub startset { my ($op) = @_; $op->{args}->[0]->startset() }
sub hasback { my ($op) = @_; $op->{args}->[0]->hasback() }
sub dfa_safe { my ($op) = @_; $op->{args}->[0]->dfa_safe() }

# Superclass for ops that match a single input atom (eg a character or
# character class.)
package Regex::Ops::Tree::_atom;

sub minlen { 1 }
sub maxlen { 1 }
sub dfa_safe { 1 }
sub hasback { 1 }

# Sequences of regexes like RS
package Regex::Ops::Tree::seq;

sub init {
    my ($self) = @_;

    if (@{ $self->{args} } == 0) {
        delete $self->{name};
        delete $self->{args};
        return $self->op('nop', [], %$self);
    } elsif (@{ $self->{args} } == 1 && 2 == keys %$self) {
        return $self->{args}->[0];
    } else {
        return $self;
    }
}

sub minlen {
    my $op = shift;
    my $minlen = 0;
    $minlen += $_->minlen() foreach @{ $op->{args} };
    return $minlen;
}

sub maxlen {
    my $op = shift;
    my $maxlen = 0;
    foreach my $kid (@{ $op->{args} }) {
        my $kidmax = $kid->maxlen();
        return undef if ! defined $kidmax;
        $maxlen += $kidmax;
    }
    return $maxlen;
}

sub startset {
    my $op = shift;
    my %start;
    foreach (@{ $op->{args} }) {
        my @next = $_->startset();
        @start{@next} = ();
        # Stop unless NULLABLE.
        last unless (@next && $next[0] eq '');
    }

    return Regex::Ops::Tree::order_startset(\%start);
}

sub dfa_safe {
    my $op = shift;
    foreach (@{ $op->{args} }) {
        return 0 unless $_->dfa_safe();
    }
    return 1;
}

# R|S
package Regex::Ops::Tree::alternate;

sub init {
    my ($self) = @_;

    if (@{ $self->{args} } == 0) {
        delete $self->{name};
        delete $self->{args};
        return $self->op('nop', [], %$self);
    } elsif (@{ $self->{args} } == 1 && 2 == keys %$self) {
        return $self->{args}->[0];
    } else {
        return $self;
    }
}

sub minlen {
    my $op = shift;
    my $min;
    foreach (@{ $op->{args} }) {
        my $len = $_->minlen();
        $min = $len if (! defined $min) || ($min > $len);
    }
    return $min || 0;
}

sub maxlen {
    my $op = shift;
    my $max = 0;
    foreach (@{ $op->{args} }) {
        my $len = $_->maxlen();
        return undef if ! defined $len;
        $max = $len if $max < $len;
    }
    return $max;
}

sub startset {
    my $op = shift;
    my %start;
    foreach (@{ $op->{args} }) {
        @start{$_->startset()} = ();
    }
    return Regex::Ops::Tree::order_startset(\%start);
}

# Returns true if at most one subexpression can ever hold at a given
# point in the input string. (Return value is conservative: this will
# return false if it is not sure.)
sub disjoint {
    my $op = shift;

    # For now, return true iff all subexpressions' startsets contain
    # only integers (no character classes or weirder things), and all
    # of those integers are different.
    my %start;
    foreach my $subop (@{ $op->{args} }) {
        my @subop_startset = $subop->startset();
        return 0 if grep { ref($_) || $_ !~ /^\d+$/ } @subop_startset;
        foreach (@subop_startset) {
            return 0 if exists($start{$_});
        }
    }

    return 1;
}

sub dfa_safe {
    my $op = shift;

    my $dfa_safe_subexprs = 1;
    foreach (@{ $op->{args} }) {
        $dfa_safe_subexprs = 0, last if ! $_->dfa_safe();
    }

    return 1 if $dfa_safe_subexprs && $op->disjoint();

    # Insert better tests here

    return 0;
}

# R*, R+, R?, nongreedy variants of those
package Regex::Ops::Tree::multi_match;

sub minlen {
    my $op = shift;
    return 0 if $op->{args}->[0] <= 0;
    return $op->{args}->[0] * $op->{args}->[3]->minlen();
}

sub maxlen {
    my $op = shift;
    my ($min, $max, $greedy, $R) = @{ $op->{args} };
    my $sublen = $R->maxlen();
    if (defined($max) && $max !~ /^-?\d+/) {
        return undef;
    } elsif (!defined($max) || $max == -1) {
        return undef if ! defined($sublen); # [m..INF]*
        return undef if $sublen > 0;        # [m..sublen]*
        return 0;                           # [0..0]*
    } else {
        return undef if ! defined($sublen); # [m..INF] repeated up to N times
        return $max * $sublen;              # [m..sublen] repeated up to N times
    }
}

sub startset {
    my $op = shift;
    my @sub = $op->{args}->[3]->startset();
    if (@sub && $sub[0] ne '') {
        if ($op->minlen() == 0) {
            return ('', @sub);
        } else {
            return @sub;
        }
    } else {
        return @sub;
    }
}

package Regex::Ops::Tree::scan;
sub maxlen { undef };

# $ (not R$, just $)
package Regex::Ops::Tree::atend;

sub minlen { 0 }
sub maxlen { 0 }
sub startset { return () }
sub hasback { 0 }
sub dfa_safe { 1 }

package Regex::Ops::Tree::nop;
sub minlen { 0 }
sub maxlen { 0 }

package Regex::Ops::Tree::check;
sub minlen { $_[0]->{args}->[1]->minlen(); }
sub maxlen { $_[0]->{args}->[1]->maxlen(); }

# Rule calls are totally unpredictable -- for now. I think some static
# analysis might not be too hard.
package Regex::Ops::Tree::call;
sub minlen { 0 }
sub maxlen { undef }
sub dfa_safe { 0 }
sub hasback { 1 }
sub startset { undef }

########################################################################
# Rendering - only used for debugging for now
########################################################################

package Regex::Ops::Tree; # Won't get used much

sub needparen { 0 }

# Nonportable
sub isplain {
    my $ord = shift;
    return 1 if $ord >= ord('a') && $ord <= ord('z');
    return 1 if $ord >= ord('A') && $ord <= ord('Z');
    return 1 if $ord >= ord('0') && $ord <= ord('9');
    return 1 if $ord =~ /^[~!@#%&_'":;>,<]$/;
#    return 1 if $ord =~ /^[`~!@#$%^&*()\-_+{}\[\]\\|'":;\/?.>,<]$/;
    return 0;
}

sub Regex::Ops::Tree::match::render {
    my $op = shift;
    my $atom = $op->{args}->[0];
    if ($atom =~ /^\d+$/) {
        return chr($atom) if isplain($atom);
        return sprintf("\\x%02x", $atom); # Nonportable
    } else {
        die;
    }
}

sub Regex::Ops::Tree::charclass::render {
    die;
}

sub Regex::Ops::Tree::seq::needparen { 0 }
sub Regex::Ops::Tree::seq::render {
    my $op = shift;
    return join('', map { $_->render() } @{ $op->{args} });
}

sub Regex::Ops::Tree::alternate::needparen { 1 }
sub Regex::Ops::Tree::alternate::render {
    my $op = shift;
    my $str = '';
    foreach my $case (@{ $op->{args} }) {
        $str .= "|" unless length($str) == 0;
        my $R = $case->render();
        $str .= $case->needparen() ? "(?:$R)" : $R;
    }

    return $str;
}

sub Regex::Ops::Tree::multi_match::needparen { 1 }
sub Regex::Ops::Tree::multi_match::render {
    my $op = shift;
    my ($min, $max, $greedy, $R) = @{ $op->{args} };
    my $base = $R->render();
    $base = "(?:$base)" if $R->needparen();
    if ($min == 0 && $max == 1) {
        $base .= "?";
    } elsif ($min == 0 && $max == -1) {
        $base .= "*";
    } elsif ($min == 1 && $max == -1) {
        $base .= "+";
    } elsif ($max == -1) {
        $base .= "{$min,}";
    } else {
        $base .= "{$min,$max}";
    }

    $base .= "?" unless $greedy;
    return $base;
}

sub Regex::Ops::Tree::group::needparen { 0 }
sub Regex::Ops::Tree::group::render {
    my $op = shift;
    my $R = $op->{args}->[0];
    my $str = $R->render();
    # Strip off (?:) from the subexpression if possible, so we can
    # render things as (R) instead of ((?:R))
    if ($str =~ /^\(\?\:(.*)\)$/) {
        $str = $1;
    }
    return "($str)";
}

# FIXME: Should render the _absence_ of this op differently!
sub Regex::Ops::Tree::scan::needparen { 0 }
sub Regex::Ops::Tree::scan::render { $_[0]->{args}->[0]->render() }

sub Regex::Ops::Tree::atend::needparen { 0 }
sub Regex::Ops::Tree::atend::render { '$' }

sub Regex::Ops::Tree::check::needparen { 0 }
sub Regex::Ops::Tree::check::render { $_[0]->{args}->[1]->render() }

########################################################################
# Dumping trees, for debugging only
########################################################################

package Regex::Ops::Tree;

sub dump_tree {
    my ($op) = @_;
    my $ref = $op->reftree();
    return dump_ref($ref);
}

sub dump_ref {
    my ($ref, $indent) = @_;
    $indent ||= "";
    print $indent;
    if (ref $ref) {
        my ($name, @children) = @$ref;
        print $name, "\n";
        dump_ref($_, $indent . "  ") foreach (@children);
    } else {
        print $ref, "\n";
    }
}

sub annotated {
    my ($op, $str) = @_;
    my $min = $op->minlen();
    my $max = $op->maxlen();
    $max = "INF" if ! defined $max;
    return "$str [$min..$max]";
}

# Defaults
sub Regex::Ops::Tree::reftree {
    my $op = shift;
    return $op->{name};
}

sub Regex::Ops::Tree::_onearg::reftree {
    my $op = shift;
    return [ annotated($op, $op->{name}), $op->{args}->[0]->reftree() ];
}

sub Regex::Ops::Tree::match::reftree {
    my $op = shift;
    return annotated($op, "match(" . $op->render(@_) . ")");
}

sub Regex::Ops::Tree::charclass::reftree {
    my $op = shift;
    return annotated($op, "charclass " . $op->render(@_));
}

sub Regex::Ops::Tree::seq::reftree {
    my $op = shift;
    return [ annotated($op, "seq"), map { $_->reftree() } @{ $op->{args} } ];
}

sub Regex::Ops::Tree::alternate::reftree {
    my $op = shift;
    my $ref = [ annotated($op, "alternate") ];
    push(@$ref, $_->reftree()) foreach (@{ $op->{args} });
    return $ref;
}

sub Regex::Ops::Tree::multi_match::reftree {
    my $op = shift;

    my ($min, $max, $greedy, $R) = @{ $op->{args} };
    my $ref = [ annotated($op, "multi_match($min .. $max)"), $R->reftree() ];
    $ref->[0] .= "?" unless $greedy;

    return $ref;
}

sub Regex::Ops::Tree::check::reftree {
    my $op = shift;
    return [ annotated($op, "check($op->{args}->[0])"),
             $op->{args}->[1]->reftree() ];
}

1;
