package Webservice::InterMine::Path;

=head1 NAME

Webservice::InterMine::Path - functions for finding problems with paths

=head1 SYNOPSIS

For validation using functions/static methods:

    use Webservice::InterMine::Path qw(:validate);

    my @errors;
    push @errors, validate_path($model, $path_string);
    push @errors, end_is_class($model, $path_string);
    push @errors, b_is_subclass_of_a($model, $path_stringA, $path_stringB);
    confess @errors if @errors;

For queries for path based information from query services:

    use Webservice::InterMine;

    my $service = Webservice::InterMine->get_testmine;
    my $path = $service->new_path('Department.employees.name');
    my $has_guessed_correctly = 0;
    for my $name ($path->get_possible_values) {
        last if $has_guessed_correctly;
        print "Is your name $name?: y|N:";
        chomp(my $resp = <STDIN>);
        $has_guessed_correctly++ if ($resp =~ /y(es)?/i);
    }

=cut

use Exporter 'import';

my @validators = qw(validate_path end_is_class b_is_subclass_of_a a_is_subclass_of_b root);
our @EXPORT_OK = ( @validators, 'type_of', 'class_of', 'next_class', 'resolve');
our %EXPORT_TAGS = ( validate => \@validators );

use strict;
use InterMine::Model::Attribute;
use Carp qw/confess croak/;

use overload (
    '""' => 'to_string',
    fallback => 1,
);

=head1 METHODS

=head2 new(Str path, Service service, [HashRef subtypes])

Construct a new path object for use with path based 
webservice. The path is immediately validated before use, 
so any subclass constraints that affect this path need 
to be included in the subtypes hash. 

This constructor is not meant to be used directly; rather, obtain
Webservice::InterMine:Path objects from their respective Service objects
via their C<new_path> methods.

=cut 

sub new {
    my $class = (ref $_[0]) ? ref shift : shift;
    my ($path, $service, $subtypes) = @_;
    $subtypes ||= {};
    my $self = {path => $path, service => $service, subtypes => $subtypes};

    $self->{parts} = [_parse($service->model, $path, $subtypes)];
    return bless $self, $class;
}

sub to_string {
    my $self = shift;
    return $self->{path} if $self->{path};
    my @parts = @{ $self->{parts} };

    join ".", $parts[0]->unqualified_name, map {$_->name} @parts[1 .. @parts - 1];
}

=head2 get_results_iterator([$format])

Return an object for iterating over rows of results. 
The formats that are supported by the possible values service
are jsonobjects (the default), and count formats. However, for accessing
counts, and even values, it is probably easier to use the 
convenience methods listed below.

=cut

sub get_results_iterator {
    my $self = shift;
    my $format = shift || 'jsonobjects';
    my $service = $self->{service};
    my $uri = $service->root . $service->POSSIBLE_VALUES_PATH; 
    require JSON;
    my $json = JSON->new;
    my $params = {
        path => $self->{path}, 
        typeConstraints => $json->encode($self->{subtypes}),
    };

    my $iter = $service->get_results_iterator(
        $uri, $params, [], $format, 'perl', []);
    return $iter;
}

=head2 set_subtype($key => $value)

Paths can be refined by adding subtype constraints after they have been
constructed. EG:

 my $path = $service->new_path("Department.employees.name")
 # now the path represents that names of employees

 $path->set_subtype("Department.employees" => "CEO");
 # And now it represents the names of CEOs

=cut

sub set_subtype {
    my $self = shift;
    my ($k, $v) = @_;
    return $self->{subtypes}{$k} = $v;
}

=head2 get_possible_values()

Returns the values this path may potentially have. Be aware
that in list context it returns, as expected, as list of values, whereas
in scalar context it resturns an Array-Reference to that list of
values. If you just want the number of items in the list, use 
C<get_possible_values_count> instead, which is much more efficient.

=cut

sub get_possible_values {
    my $self = shift;
    my $iter = $self->get_results_iterator;
    my @values = map {$_->{value}} $iter->get_all;
    if (wantarray) {
        return @values;
    } else {
        return [@values];
    }
}

=head2 get_possible_values_count()

Returns the number of different values this path may represent. 
This is the most efficient way to retrieve this information from the server.

=cut

sub get_possible_values_count {
    my $self = shift;
    my $iter = $self->get_results_iterator('count');
    return join('', $iter->get_all);
}

=head2 end_is_attribute()

Return true if this object represents a path that ends in an 
attribute.

=cut

sub end_is_attribute {
    my $self = shift;
    my $end = $self->last_bit;
    if (class_of($end)) {
        return 0;
    } else {
        return 1;
    }
}

=head2 prefix()

Return the path before this one. eg, for "Gene.exons.name", return
a path representing "Gene.exons". The resulting path with have all the same
data as this one, including subclass information.

=cut

sub prefix {
    my $self = shift;
    my %hash = %{ $self };
    delete $hash{path};
    my @parts = @{ $self->{parts} };
    pop @parts;
    die $self->to_string . " has no prefix" unless @parts;
    $hash{parts} = [@parts];
    $hash{subtypes} = { %{ $self->{subtypes} } };
    return bless \%hash, (ref $self);
}

=head2 append(@parts)

Return a path representing a path made from this one with further
parts added on. Eg, for a path representing "Gene.exons", a call to 
C<< $path->append("name") >> should return a path representing 
"Gene.exons.name".

=cut

sub append {
    my ($self, @parts) = @_;
    return Path->new($self->to_string . "." . join('.', @parts), 
        $self->{service}, $self->{subtypes});
}

=head1 FUNCTIONS

=head2 validate_path

 Usage   : validate_path($model, 'Department.name');
 Function: Return errors for this path, nothing if the path is valid
 Args    : $model - the InterMine::Model to use for validating
           $path_string - the path in string format

=cut

sub validate_path {

    # Since errors returned should only relate to the path
    # we will confess arg errors here
    confess "Bad arguments: Too many" if ( @_ > 4 );
    confess "Bad arguments: Too few"  if ( @_ < 2 );
    confess "Bad arguments: No pathstring, or not a string"
      if ( ref $_[1] or not defined $_[1] );
    confess "Bad arguments: Third arg is not a hash"
      if ( defined $_[2] and ref $_[2] ne 'HASH' );
    confess "Bad Arguments: No model as first arg"
      if ( not $_[0]->isa('InterMine::Model') );

    eval { _parse(@_) };
    if ($@) {
        return $@;
    }
    else {
        return undef;
    }
}

=head2 last_bit

 Usage   : last_bit($model, 'Department.name');
 Function: Returns the metaclass for the last part of the path-string
 Args    : $model - the InterMine::Model to use for validating
           $path_string - the path in string format

=cut

sub last_bit {
    # Called as method
    return $_->{parts}[-1] if (@_ == 1);
    # Called as fn.
    my ( $model, $path_string, $types) = @_;
    my @bits = _parse( $model, $path_string, $types);
    return $bits[-1] || $bits[0];
}

sub last_bit_but_one {
    my ( $model, $path_string, $types) = @_;
    my @bits = _parse( $model, $path_string, $types);
    return $bits[-2] || $bits[0];
}
sub last_class_type {
    my ( $model, $path_string ) = @_;
    my $end = last_bit_but_one( $model, $path_string );
    if ( $end->isa('InterMine::Model::Reference') ) {
        return $end->referenced_type_name;
    } else {
        return $end->name();    # because it's clearly a class
    }
}

=head2 resolve

Resolves a path to a class descriptor, or an attribute descriptor.

=cut 

sub resolve {
    my $bit;
    if (@_ == 1) {
        # Calling as method
        $bit = $_[0]->{parts}[-1];
    } else {
        # Calling as fn.
        my ( $model, $string, $types) = @_;
        $bit = last_bit($model, $string, $types);
    }
    return class_of($bit) || $bit;
}

=head2 type_of

 Usage    : type_of($model, 'Department.name');
 Function : returns a string with the type that this string evaluates to
            ie: Department.name => String
                Department.employees => Employee

=cut

sub type_of {
    my ( $model, $path_string ) = @_;
    my $end = last_bit( $model, $path_string );
    if ( $end->isa('InterMine::Model::Reference') ) {
        return $end->referenced_type_name;
    }
    elsif ( $end->isa('InterMine::Model::Attribute') ) {
        return $end->attribute_type;
    }
    else {
        return $end->name();    # because it's clearly a class
    }
}

=head2 end_is_class

 Usage   : end_is_class($model, 'Department.name');
 Function: Returns an error if the last bit does not evaluate to a class (ie. is an attribute)
 Args    : $model - the InterMine::Model to use for validating
           $path_string - the path in string format

=cut

sub end_is_class {
    my $end = (@_ == 1) ? $_[0]->{parts}[-1] : eval { last_bit(@_) };
    if ($end) {
        if ( not class_of($end) ) {
            return sprintf( "%s: %s is a %s, not a class\n",
                $_[1], $end->name, $end->attribute_type, );
        }
        else {
            return undef;
        }
    }
    else {
        return validate_path(@_);
    }
}

=head2 a_is_subclass_of_b($model, $classA, $classB)

Returns undef if $classA represents a subclass of $classB, or
if they do not represent valid paths, otherwise returns a message.

=cut 

sub a_is_subclass_of_b {
    my ( $model, $path_stringA, $path_stringB ) = @_;
    return b_is_subclass_of_a($model, $path_stringB, $path_stringA);
}

=head2 b_is_subclass_of_a($model, $classA, $classB)

Returns undef if $classA represents a subclass of $classB, or
if they do not represent valid paths, otherwise returns a message.

=cut

sub b_is_subclass_of_a {
    my ( $model, $path_stringA, $path_stringB ) = @_;

    my ( $A, $B ) = eval {
        map { class_of( last_bit( $model, $_ ) ) }
          $path_stringA,
          $path_stringB;
    };
    return undef unless ( $A and $B );

    # invalid paths are not MY problem
    # - go see Mr. validate_path
    if ( $B->sub_class_of($A) ) {
        return undef;
    }
    else {
        return
          sprintf(
            "%s (which is a %s) is not a subclass of %s (which is a %s)\n",
            $path_stringB, $B->name, $path_stringA, $A->name, );
    }
}

sub root {
    if (@_ == 1) {
        my $self = shift;
        return $self->{parts}[0];
    }
    my ($root) = _parse(@_);
    return $root;
}

sub _parse {
    my ( $model, $path_string, $type_hashref ) = @_;

    $type_hashref ||= {};

    if ($ENV{DEBUG}) {
        require Data::Dumper;
        warn "SUBTYPES: " . Data::Dumper->Dump([$type_hashref]);
    }

    # split Path.string into 'Path', 'string'
    my @bits = split /\./, $path_string;
    my @parts = ();    # <-- the classdescriptors will go here

    my $top_class_name = shift @bits;
    my @processed_bits = ($top_class_name); # <-- to track what we have looked at
    confess "model is not defined" unless ( defined $model );
    push @parts, $model->get_classdescriptor_by_name($top_class_name);

    my $current_class = $parts[-1];
    my $current_field = undef;

    for my $bit (@bits) {

        if ( $bit eq 'id' and $bit eq $bits[-1] ) {
            my $id = InterMine::Model::Attribute->new(
                name        => $bit,
                type        => 'Integer',
                model       => $model,
                field_class => $current_class,
            );
            push @parts, $id;
        }
        else {
            $current_field = $current_class->get_field_by_name($bit);
            if ( !defined $current_field ) {
                my $subclass_key = join('.', @processed_bits);
                warn "COULDN'T FIND $bit, CHECKING SUBCLASSES FOR $subclass_key" if $ENV{DEBUG};
                if ( my $type = $type_hashref->{ $subclass_key } ) {
                    warn "IT MAY BE IN $type" if $ENV{DEBUG};
                    my $type_class = $model->get_classdescriptor_by_name($type);
                    $current_field = $type_class->get_field_by_name($bit);
                }
                if ( !defined $current_field ) {
                    my $message = sprintf(
                        qq{illegal path (%s): can't find field "%s" in class "%s"},
                        $path_string,
                        $bit,
                        $current_class->name(),
                    );
                    if ($ENV{DEBUG}) {
                        confess $message;
                    } else {
                        croak $message;
                    }
                }
            }
            push @parts, $current_field;
            my $type =  $type_hashref->{join('.', map {$_->name} @parts)};
            $current_class =
              next_class( $current_field, $model, $type );
        }
        push @processed_bits, $bit;
    }
    return @parts;
}

sub next_class {
    my ( $current_field, $model, $type ) = @_;
    return undef
      if $current_field->isa('InterMine::Model::Attribute');

    # if the type was given, respect it
    my $next_class;
    if ( $type ) {
        $next_class = $model->get_classdescriptor_by_name($type);
    }
    else {
        $next_class = class_of($current_field);
    }
    confess "Could not find next class for " . $current_field->name
      unless ($next_class);
    return $next_class;
}

=head2 class_of

 Usage   : class_of($instance);
 Function: Returns the meta-class that an object refers to.
 Args    : an Webservice::InterMine::Field or ClassDescriptor instance

=cut

sub class_of {
    my $thing = shift;
    if ( $thing->isa('InterMine::Model::Reference') ) {
        return $thing->referenced_classdescriptor();
    }
    elsif ( $thing->isa('InterMine::Model::ClassDescriptor') ) {
        return $thing;
    }
    else {
        return;
    }
}
1;

=head1 AUTHOR

FlyMine C<< <support@flymine.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<support@flymine.org>.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Webservice::InterMine::Path

You can also look for information at:

=over 4

=item * FlyMine

L<http://www.flymine.org>

=back

=head1 COPYRIGHT & LICENSE

Copyright 2009,2010 FlyMine, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut