package MooseX::Meta::CompiledParameter;

use Moose;

use B::Deparse;
use Moose::Util::TypeConstraints;
use MooseX::Method::Constant;
use MooseX::Method::Exception;
use Scalar::Util qw/blessed/;

has isa             => (isa => 'Str | Object');
has does            => (isa => 'Str');
has required        => (isa => 'Bool');
has default         => (isa => 'Str | CodeRef');
has coerce          => (isa => 'Bool');

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

  if (defined $self->{isa}) {
    if (blessed ($self->{isa})) {
      if ($self->{isa}->isa ('Moose::Meta::TypeConstraint')) {
        $self->{type_constraint} = $self->{isa};
      } else {
        MooseX::Method::Exception->throw ("You cannot specify an object as type if it's not a type constraint");
      }
    } else {
      if ($self->{isa} =~ /\|/) {
        my @type_constraints = split /\s*\|\s*/,$self->{isa};

        $self->{type_constraint} = Moose::Util::TypeConstraints::create_type_constraint_union (@type_constraints);
      } else {
        my $constraint = find_type_constraint ($self->{isa});     
          
        $constraint = subtype ('Object',where { $_->isa ($self->{isa}) })
          unless defined $constraint;

        $self->{type_constraint} = $constraint;
      }
    }
  }

  if ($self->{coerce}) {
    MooseX::Method::Exception->throw ("You cannot set coerce if type does not support this")
      unless defined $self->{type_constraint} && $self->{type_constraint}->has_coercion;
  }

  $self->{compiled} = $self->compile;

  return;
}

sub validate {
  my $self = shift;

  return $self->{compiled}->(@_);
}

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

  my $code = '';

  $code .=<<"EOF";
sub {
  my (\$value) = \@_;

  my \$provided = (\$#_ >= 0 ? 1 : 0);
EOF

  $code .= $self->as_perl;

  $code .=<<"EOF";
  return \$value;
};
EOF

  my $coderef = eval $code;

  MooseX::Method::Exception->throw ("Compilation failed: $@")
    if ($@);

  return $coderef;
}

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

  my $code = '';

  if (defined $self->{default}) {
    if (ref $self->{default} eq 'CODE') {
      my $default = MooseX::Method::Constant->make ($self->{default});

      $code .=<<"EOF";
unless (\$provided) {
  \$value = $default->(\$self);

  \$provided = 1;
}
EOF
    } else {
      my $default = quotemeta ($self->{default});

      $code .=<<"EOF";
unless (\$provided) {
  \$value = "$default";

  \$provided = 1;
}
EOF
    }
  }

  if (defined $self->{type_constraint} || defined $self->{does}) {
    $code .=<<"EOF";
if (\$provided) {
EOF

    if (defined $self->{type_constraint}) {
      $code .= $self->_constraint_as_perl ($self->{type_constraint},$self->{coerce});
    }

    if (defined $self->{does}) {
      my $does = quotemeta $self->{does};

      $code .=<<"EOF";
  MooseX::Method::Exception->throw ("Does not do ($does)")
    unless Scalar::Util::blessed (\$value) && \$value->can ('does') && \$value->does ("$does");
EOF
    }

    $code .=<<"EOF";
}
EOF

    if ($self->{required}) {
      $code .=<<"EOF";
else {
  MooseX::Method::Exception->throw ("Must be specified");
}
EOF
    }
  } elsif ($self->{required}) {
    $code .=<<"EOF";
MooseX::Method::Exception->throw ("Must be specified")
  unless (\$provided);
EOF
  }

  return $code;
}

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

  my $safe = 0;

  if ($constraint->has_hand_optimized_type_constraint) {
    for (qw/Int ArrayRef/) {
      $safe = 1 if $constraint->name eq $_;
    }
  }

  my $check_code;

  my $constant_constraint;
 
  if (!$safe || $coerce) {
    $constant_constraint = MooseX::Method::Constant->make ($constraint);
  }

  if ($safe) {
    my $deparse = B::Deparse->new;

    $deparse->ambient_pragmas (strict => 'all',warnings => 'all');

    $check_code = $deparse->coderef2text ($constraint->hand_optimized_type_constraint);

    $check_code =~ s/(?:package.*;$)//g;
    
    $check_code =~ s/\$_\[0\]/\$value/g;

    $check_code = "do $check_code";
  } else {
    $check_code = "$constant_constraint->check (\$value)";
  }

  my $code = '';

  $code .=<<"EOF";
unless ($check_code) {
EOF

  if ($coerce) {
    $code .=<<"EOF";
  \$value = $constant_constraint->coerce (\$value);

  unless ($check_code)
EOF
  }

  $code .=<<"EOF";
  {
    MooseX::Method::Exception->throw ("Argument isn't a ($self->{isa})");
  }
}
EOF

  return $code;
}

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

  my $export = {};
  
  for (keys %$self) {
    $export->{$_} = $self->{$_} if defined $self->{$_};
  }

  for (qw/compiled/) {
    delete $export->{$_};
  }

  return $export;
}

__PACKAGE__->meta->make_immutable;

1;

__END__

=pod

=head1 NAME

MooseX::Meta::Parameter - Parameter metaclass

=head1 WARNING

This API is unstable, it may change at any time. This should not
affect ordinary L<MooseX::Method> usage.

=head1 SYNOPSIS

  use MooseX::Meta::Parameter;

  my $parameter = MooseX::Meta::Parameter->new (isa => 'Int');

  my $result;

  eval {
    $result = $parameter->validate ("foo");
  };

  print Dumper($parameter->export);

=head1 METHODS

=over 4

=item B<validate>

Takes an argument, validates it, and returns the argument or possibly
a coerced version of it. Exceptions are thrown on validation failure.

=item B<as_perl>

Produces a string of optimized perl for inlining the validation. The
current level of optimization is sub-optimal (No pun intended) but will
eventually improve.

=item B<export>

Exports a data structure representing the parameter.

=back

=head1 BUGS

Most software has bugs. This module probably isn't an exception. 
If you find a bug please either email me, or add the bug to cpan-RT.

=head1 AUTHOR

Anders Nor Berle E<lt>debolaz@gmail.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2007 by Anders Nor Berle.

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

=cut

