package RDF::UL1;

$::RD_HINT++;

use Parse::RecDescent;
use Carp;
use strict;
use vars qw( $Object );

local $Object = __PACKAGE__;

our @Node = qw( subject predicate object );

our $Grammar = q%
Query: ( Fetch 
    | Assert 
    | Retract
    | Infer
    | Use
    | Import ) /\Z/ { $return = $item[1] }
    | <error>

Assert: 'assert' Phrase
    { $return = [ assert => @{$item{Phrase}} ] }

Retract: 'retract' Phrase

Infer: 'infer' Constraint 'when' Phrase

Use: 'use' Alias(s /,/) 
    { $return = [ alias => map(@$_, @{$item[2]}) ] }

Using: 'using' Alias(s /,/)
    { $return = [ map(@$_, @{$item[2]}) ] }

Alias: Identifier 'for' URI 
    { $return = [ $item{Identifier}, ${$item{URI}} ] }

Fetch: 'fetch' ('where')(?) Phrase Using(?)
    { $return = [ fetch_aliased => $item[4][0], @{$item{Phrase}} ] }

Import: 'import' ('from')(?) URI
    { $return = [ import_uri => $item{URI} ] }

Phrase: 
      Constraint And Phrase
	{ $return = [ $item{Constraint}, @{$item{Phrase}} ] }
    | Constraint 
	{ $return = [ $item{Constraint} ] }
    | '(' Phrase ')'
	{ $return = $item{Phrase} }

Constraint: Subject Negation(?) Predicate Object  { 
    my @triple = @item{qw/ Subject Predicate Object /};
    my $constraint = RDF::UL1::Constraint->new(@triple);
    $return = $constraint
} 

Negation: 'not'

And: "," | "and"

Conjoint: 'or'

Subject: Variable
    | URI
    | Procedure

Predicate: URI
    | Variable
    | Operator { $return = eval "sub { \$_[0] $item{Operator} \$_[1] }" }

Operator:
       '=' { "eq" }
    | '!=' { "ne" }
    | '<'  
    | '>'
    | '<='
    | '>='
    | '~' { "=~" }

Object: Subject
    | Literal

Literal: String
    | Number

String: /"([^"]+)"/
    { $return = $1 }

Number: /-?\d+(.\d+)*/

Procedure: Identifier '(' Object ')'

Variable: /\?(\w[^\s,]*)/ { $return = RDF::UL1::Variable->new($1) }

Identifier: /\w[^\s,]*/

URI: /\w+:[^\s,]+|#[^\s,]+/ { $return = RDF::UL1::URI->new($item[1]) }

%;

sub RDF::UL1::Variable::new {
    my ($type, $var) = @_;
    bless \$var, $type;
}


sub RDF::UL1::URI::new {
    my ($type, $var) = @_;
    bless \$var, $type;
}
sub RDF::UL1::Constraint::new {
    my ($type, @triple) = @_;
    bless \@triple, $type;
}

sub RDF::UL1::Constraint::subject   { $_->[0] }
sub RDF::UL1::Constraint::predicate { $_->[1] }
sub RDF::UL1::Constraint::object    { $_->[2] }

sub new {
    my ($class, %args) = @_;
    my $self = bless \%args, ref($class) || $class;
    croak "Missing required model argument" unless $self->model;
    $self->{parser} = Parse::RecDescent->new( $Grammar );
    $self->prefix( $self->{prefix} ) if $self->{prefix};
    return $self;
}

sub model {
    my $self = shift;
    $self->{model} = shift if @_;
    return $self->{model};
}

sub rdf_parser {
    my $self = shift;
    $self->{rdf_parser} ||= RDF::Redland::Parser->new;
}


sub prefix {
    my $self = shift;
    if (my $hash = shift) {
	$self->{prefix_name} = $hash;
	$self->{prefix_uri}  = {reverse %$hash};
	$self->{prefix_name_re} = join("|", keys %$hash);
	$self->{prefix_uri_re}  = join("|", values %$hash);
    }
    return $self->{prefix_name} || {};
}

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

    @statement = map( $statement[0]->$_, @Node )
	if ref $statement[0] eq "RDF::Redland::Statement";

    for (@statement) {
	if (ref $_ eq "RDF::Redland::Node") {
	    if ($_->is_resource) {
		$_ = RDF::UL1::URI->new( $_->uri->as_string );
	    } else {
		$_ = $_->as_string;
	    }
	}
    }

    RDF::UL1::Constraint->new( @statement );
}

sub is_uri {
    my ($self, $node) = @_;
    return ref($node) eq "RDF::UL1::URI";
}

sub is_variable {
    my ($self, $node) = @_;
    return ref($node) eq "RDF::UL1::Variable";
}

sub is_comparison {
    my ($self, $node) = @_;
    return ref($node) eq "CODE";
}

sub statement {
    my $self = shift;
    my @nodes = map($self->node($_), @_);
    RDF::Redland::Statement->new(@nodes);
}

sub node {
    my ($self, $literal) = @_;
    return undef unless defined $literal;
    if ($self->is_uri($literal)) {
	return $self->uri($$literal);
    } 
    RDF::Redland::Node->new($literal);
}

sub uri {
    my $self = shift;
    my $uri  = shift;
    $uri = $$uri if $self->is_uri($uri);
    $uri =~ s/^($self->{prefix_name_re}):/$self->{prefix_name}{$1}/s
	if $self->{prefix_name_re};
    $uri = $self->{base} . $uri unless $uri =~ /^\w+:/o;
    RDF::Redland::URI->new($uri);
} 

sub stringify {
    my ($self, $node) = @_;
    my $val = $node->as_string;
    $val = qq{"$val"} if $node->is_literal;
    if ($node->is_resource) {
	$val =~ s/^\[$self->{base}(.+)]/$1/s;
	$val =~ 
	    s/^\[($self->{prefix_uri_re})(.*?)\]$/$self->{prefix_uri}{$1}:$2/s
	    if $self->{prefix_name_re};
    }
    return $val;
}

sub query {
    my ($self, $query) = @_;
    local $Object = $self;
    my $tree = $self->{parser}->Query( $query ) 
	or die "Error parsing $query";
    # use Data::Dumper; warn Dumper $tree;
    my $handler = $self->can( shift @$tree );
    return $self->$handler( $tree );
}

sub assert {
    my ($self, $tree) = @_;
    for my $triple (@$tree) {
	my $assertion = $self->statement( @$triple );
	$self->model->add_statement( $assertion );
    }
}    

sub alias {
    my ($self, $tree) = @_;
    my %prefix = ( %{$self->prefix}, @$tree );
    $self->prefix(\%prefix);
    return 0;
}

sub import_uri {
    my ($self, $tree) = @_;
    my $source = $self->uri( shift @$tree );
    $self->rdf_parser->parse_into_model($source, $source, $self->model);
}

sub fetch_aliased {
    my ($self, $const) = @_;
    if (my $ns = $const->[0]) {
	$self->alias($ns);
    }
    return $self->fetch([@$const[1..$#$const]]);
}

sub fetch {
    my ($self, $constraints, $var) = (@_, {});
    my ($const, @rest) = @$constraints;
    return [] unless $const; ### ???
 
    my @triple = @$const;
    my (@unbound, @results);

    for my $n (0 .. $#triple) {
	my $node = $triple[$n];
	if ($self->is_variable($node)) {
	    if (defined $var->{$$node} ) {
		$triple[$n] = $var->{$$node};
	    } else {
		push @unbound, $n;
	    }
	}
    }

    if (@unbound) {
	my %assign;
	for my $n (@unbound) {
	    my $node = $triple[$n]; undef $triple[$n];
	    $assign{$$node} = $Node[$n];
	}
	my $query  = $self->statement(@triple);
	my $stream = $self->model->find_statements($query) or return;
	until ($stream->end) {
	    my $match = $stream->current;
	    my %var   = %$var;
	    while (my ($name, $node) = each %assign) {
		no strict;
		$var{$name} = $match->$node;
	    }
	    my @matching = $self->fetch(\@rest, \%var);
	    push @results, [ $self->constraint($match), @$_ ] for @matching;
	    $stream->next;
	}
    } 
    elsif ($self->is_comparison( $triple[1] )) { # evaluate operator comparisons
	for (grep( ref $_, @triple[0,2])) {
	    $_ = $_->is_resource ? $_->uri->as_string : $_->as_string;
	}
	@results = [] if $triple[1]->(@triple[0, 2]);
    } 
    else { 
	my $query = $self->statement( @triple ); 
	@results = [ $self->constraint( @triple ) ]
	    if $self->model->contains_statement( $query );
    } 

    return @results;
}

1;