Perl6::Subs - Define your subroutines in the Perl 6 style

  use Perl6::Subs;

  sub foo ($x)                     # Positional parameters
    { bar($x) }

  sub get (Array $x)               # Type validation
    { pop @$x }

  sub get_or_die ($x of Array where { @$_ })  # Subtyping
    { pop @$x }

  sub show (Str $s, IO ?$io)       # Optional parameters
    { print { $io || *STDOUT } $s }

  sub limit (Int $i, Int +$hi, Int +$low)  # Named parameters
    { ... }

  method foo                       # Invocant: '$self'
    { $self->bar }

  method foo (Foo $self: Bar $x)   # Parameter 'isa' classname
    { $self->use_bar($x) }

    sub foo is method {...}
    sub foo returns(Any) is method {...}
    sub foo ($self:) : method {...}
    method foo {...}
    method foo ($self:) {...}

    sub foo : method {...}

    sub foo (Int $i)

    sub foo ($i of Int)

    sub foo (Int +$i is required)

    sub foo (+$i of Int is required)

    sub foo (Int where { $_ > 0 } $i)

    sub foo ($i of Int where { $_ > 0 })

# $Id: Subs.pm,v 1.16 2005/04/13 22:10:42 chip Exp $

package Perl6::Subs;

our $VERSION = '0.05';

use strict;
use warnings;
use Text::Balanced qw( extract_codeblock );

#
# Modules required for use by generated code
#

##use Params::Validate ();
use Scalar::Util ();


#----------------------------------------------------------------
# Debugging
#

our $DEBUG ||= $ENV{PERL6_SUBS_DEBUG} || 0;


#----------------------------------------------------------------
# Misc patterns
#

our $word_rx = qr{ ( [[:alpha:]_] \w* (?: :: [[:alpha:]_] \w* )* ) \b }x;

sub _inside {
    my $x = shift;
    if (defined $x) { $x =~ s/^[\({]//; $x =~ s/[\)}]\z// }
    $x;
}


#################################################################
# Perl6::Subs::Type
#

{
    package Perl6::Subs::Type;

    use Class::Struct
      __PACKAGE__, {
		    name    => '$',  # opt
		    base    => '$',  # opt
		    mustdef => '$',  # opt
		    qual    => '$',  # opt - built-in       - use _VAL_
		    where   => '$',  # opt - user-specified - use $_
		    valid   => '$',  # opt - P::V spec
		   };

    my %BASIC_TYPE;
    {
	my $reftype = 'Scalar::Util::reftype';

	my %t = (
		 # catch-all
		 Any	=> {},

		 # basic boxed types
		 Str	=> {},
		 Num	=> { qual => q{ Scalar::Util::looks_like_number(_VAL_) } },
		 Int	=> { base => 'Num',
			     qual => q{ int(_VAL_) == _VAL_ } },
		 Ref	=> { qual => q{ ref(_VAL_) } },
		 Bool	=> {},

		 # basic unboxed types: don't allow undefs
		 str	=> { base => 'Str',  mustdef => 1 },
		 num	=> { base => 'Num',  mustdef => 1 },
		 int	=> { base => 'Int',  mustdef => 1 },
		 ref	=> { base => 'Ref',  mustdef => 1 },
		 bool	=> { base => 'Bool', mustdef => 1 },

		 # aggregates
		 Array	=> { qual => qq{ $reftype(_VAL_) eq 'ARRAY'  } },
		 Hash	=> { qual => qq{ $reftype(_VAL_) eq 'HASH'   } },

		 # runnables
		 Code	=> { qual => qq{ $reftype(_VAL_) eq 'CODE'   } },

		 # etc.
		 Rule   => { qual => qq{ ref(_VAL_) eq 'Regexp'      } },
		 IO	=> { qual =>
				qq{ (   $reftype(_VAL_)  eq 'IO'
				     				     || $reftype(_VAL_)  eq 'GLOB'
				     				     || $reftype(\_VAL_) eq 'GLOB' ) } },

		 # Kludge Alert:
		 #   Perl 5 has these; Perl 6 doesn't,
		 #   but they're handy enough anyway
		 Glob	=> { qual => qq{ $reftype(\_VAL_) eq 'GLOB'  } },
		 GlobRef=> { qual => qq{ $reftype(_VAL_)  eq 'GLOB'  } },
		);

	for (keys %t) {
	    my %init = %{ $t{$_} };

	    delete $init{base};

	    for ($init{qual}) {
		next unless defined;
		s/^\s+//;
		s/\s+$//;
		s{ [ ]* \n [ ]* }{ }xg;
	    }

	    $BASIC_TYPE{$_} = Perl6::Subs::Type->new( name => $_, %init );
	}

	for (keys %t) {
	    if (my $b = $t{$_}{base})
	      { $BASIC_TYPE{$_}->base( $BASIC_TYPE{$b} ) }
	}
    };

    #
    # alternate constructor
    #

    sub build {
	my ($class, %args) = @_;
	my ($name, $where, $valid) = @args{qw( name where valid )};

	my $type = ( $BASIC_TYPE{$name || 'Any'}
		     || Perl6::Subs::Type->new( name => $name,
						qual => qq{ UNIVERSAL::isa(_VAL_, ${name}::) } ) );

	$type = Perl6::Subs::Type->new( base  => $type,
					where => $where,
					valid => $valid )
	      if $where || $valid;

	$type;
    }
}


#################################################################
# Common functions for Class::Struct classes.
# (Must do it this way because ISA and Class::Struct don't mix.)
#

my $CS_has_trait =
  sub {
      my ($self, $trait) = @_;
      exists $self->traits->{$trait};
  };


#################################################################
# Perl6::Subs::Param
#

{
    package Perl6::Subs::Param;

    use Class::Struct
      __PACKAGE__, {
		    name      => '$',	# formal name (no package)
		    traits    => '%',	# traits
		    type      => '$',	# type object
		   };

    sub has_trait;
    *has_trait = $CS_has_trait;
}


#################################################################
# Perl6::Subs::Sub
#

{
    package Perl6::Subs::Sub;

    use Parse::RecDescent;

    use Class::Struct
      __PACKAGE__, {
		    name      => '$',	# declared name (may not be full name)
		    traits    => '%',	# traits
		    p_inv     => '$',	# invocant (iff $self->has_trait('method'))
		    p_pos     => '@',	# positional parameters (may be empty)
		    p_pos_req => '$',	# number of p_pos that are required
		    p_named   => '%',	# named parameters (may be empty)
		    p_slurpy  => '$',	# slurpy parameter (optional)
		   };

    sub has_trait;
    *has_trait = $CS_has_trait;

    local $::RD_TRACE = $ENV{PERL6_SUBS_RD_TRACE};  # FIXME
    local $::RD_HINT  = $ENV{PERL6_SUBS_RD_HINT};   # FIXME

    my $Parser = Parse::RecDescent->new(q{

		{
	    	    our $pcomma = qr{ , | (?= \s* \) | \s* \z ) }x;   # comma _or_ end of prototype
	    	    our $word   = $Perl6::Subs::word_rx;
	    	    our $s_var  = qr{ \$   $word }x;
	    	    our $a_var  = qr{ [@%] $word }x;

	    	    our $Any_Type = Perl6::Subs::Type->build( name => 'Any' );
		}

		sub	: m{ sub \b | method \b }x
		  		  ( /$word/ )(?)
		  		  proto(?)
		  		  sub_traits
		  		  m{ (?= \\\{ | ; | \z ) }x
		    		    {
						my $sub = Perl6::Subs::Sub->new(
														name   => $item[2][0],
														traits => $item{sub_traits},
														@{ $item{'proto(?)'}[0] },
						       						       );

						#
						# C<method foo> means C<sub foo :method>
						#

						$sub->traits('method', undef)
			  			  if $item[1] eq 'method';

						#
						# If sub is a method, then it must have an invocant
						# If sub is not a method, then it must not have one.
						#
						# FIXME: '$self' is not necessarily a universal default.
						#

						if ($sub->has_trait('method')) {
			    			    $sub->p_inv( Perl6::Subs::Param->new( name => '$self',
								  								  type => $Any_Type ) )
			      			      unless $sub->p_inv;
						}
						else {
			    			    die "Invocant is only permitted for methods; use 'method' keyword or trait"
			      			      if $sub->p_inv;
						}

						# return Sub object

						$sub;
		    		    }

		proto	: { $thisparser->{local}{seen} = {} }	# FIXME: Use This
		  		  '('
		    		    inv(?)
		    		    pos(s?)
		    		    (
						opt(s)		    { [ opt    => $item[1] ] }
		      		      | named(s) slurpy(?)  { [ named  => $item[1], slurpy => $item[2][0] ] }
		      		      | slurpy		    { [ slurpy => $item[1] ] }
		      		      |			    { [] }
		    		    )
		  		  ')'
		    		    {
						my %p = (
				 				 inv => $item{'inv(?)'}[0],
				 				 pos => $item{'pos(s?)'},
				 				 @{ $item[5] },
								);

						if (@{ $p{named} || [] } && ($p{slurpy} && $p{slurpy}->name !~ /^%/))
			  			  { die "Slurpy parameter must be hash after named parameters (e.g. \"*%foo\")" }

						[
			  			  p_inv     => $p{inv},
			  			  p_pos     => [
										@{ $p{pos}       },
										@{ $p{opt} || [] },
				       				       ],
			  			  p_pos_req => scalar @{ $p{pos} },
			  			  p_named   => { map { $_->name => $_ } @{ $p{named} || [] } },
			  			  p_slurpy  => $p{slurpy},
						]
		    		    }

		inv	: param[ qr//,   $s_var, qr/:/   ]
		pos	: param[ qr//,   $s_var, $pcomma ]
		opt	: param[ qr/\?/, $s_var, $pcomma ]
		named	: param[ qr/\+/, $s_var, $pcomma ]
		slurpy	: param[ qr/\*/, $a_var, $pcomma ]

		param	: typeq /$arg[0]/ /$arg[1]/             traits /$arg[2]/
		    		    { Perl6::Subs::Param->new( name   => $item[3],
					       					       type   => $item{typeq},
					       					       traits => $item{traits} ) }

				|       /$arg[0]/ /$arg[1]/ /of\b/ type traits /$arg[2]/
		    		    { Perl6::Subs::Param->new( name   => $item[2],
					       					       type   => $item{type},
					       					       traits => $item{traits} ) }

		var	: /$arg[0]/

		type	: /$word/ where(?)
		    		    { Perl6::Subs::Type->build( name => $item[1],
												@{ $item[2][0] || [] } ) }

		typeq	: type
				| { Perl6::Subs::Type->build( name => 'Any' ) }

		where	: m{ where \b | valid \b }x <perl_codeblock>
		    		    {
		      		      my $code = $item[2];

		      		      #
		      		      # KLUDGE ALERT
		      		      # Assume they need a 'do' block if there's a ';' or 'my' in there.
		      		      # Otherwise just give them parentheses.
		      		      #
		      		      for ($code) {
						if (/;/ || m{ \b my \b }x)
			  			  { $_ = "do $_" }
						else
			  			  { s#^{#(#; s#}\z#)# }
		      		      }

		      		      [ $item[1], $code ]
		    		    }

		# 'traits' returns a hash ref to ( name => value ) trait pairs
		# 'trait' returns an array ref to a [ name, value ] trait pair

		traits		: trait(s?)		{ +{ map { @$_ } @{ $item[1] } } }
		sub_traits	: sub_trait(s? /,?/)	{ +{ map { @$_ } @{ $item[1] } } }

		trait		: /is\b/ /$word/ trait_param(?) { [ $item[2], $item[3][0] ] }

		sub_trait	: trait
						| /:/ /$word/ trait_param(?)	{ [ $item[2], $item[3][0] ] }
						| /returns\b/ trait_param	{ [ @item[1, 2] ] }

		trait_param	: <perl_codeblock ()>		{ Perl6::Subs::_inside($item[1]) }

        });


    sub new_from_decl {
	my ($class, $text) = @_;

	my $orig_len = length($text);

	local $::RD_TRACE = $ENV{PERL6_SUBS_RD_TRACE};  # FIXME
	local $::RD_HINT  = $ENV{PERL6_SUBS_RD_HINT};   # FIXME

	my $sub = $Parser->sub(\$text)
	  or return;

	wantarray
	  ? ($sub,
	     substr($_[1], 0, length($_[1]) - length($text)),
	     $text)
	  : $sub;
    }


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

	my $code = '';

	my @pos     = @{ $self->p_pos     };
	my $pos_req =    $self->p_pos_req;
	my %named   = %{ $self->p_named   };
	my $slurpy  =    $self->p_slurpy;

	#
	# For parameter passing, invocant is just positional,
	#  so include invocant in @pos and $pos_req.
	# (Hm, I wonder whether I should just fix p_pos.)
	#

	if (my $inv = $self->p_inv) {
	    unshift @pos, $inv;
	    ++$pos_req;
	}

	#
	# Enforce minimum and maximum parameter counts (if any).
	#

	if (!%named && !$slurpy && $pos_req == @pos) {
	    # min/max are the same
	    $code .= qq{    Perl6::Subs::_error "Parameter count is wrong (expected $pos_req)" if \@_ != $pos_req;\n};
	}
	else {
	    # minimum and/or maximum differ

	    $code .= qq{    Perl6::Subs::_error "Too few parameters (min $pos_req)" if \@_ < $pos_req;\n};
	    unless (%named or $slurpy) {
		my $max = @pos;
		$code .= qq{    Perl6::Subs::_error "Too many parameters (max $max)" if \@_ > $max;\n};
	    }
	}

	#
	# Grab positional, slurpy, and named all at once.
	#

	# named param variable should be an array if we're using Params::Validate

	{
	    my $named_var = $slurpy ? $slurpy->name : '%_perl6_named_params';
	    die "BUG: named slurp not a hash" if %named && $named_var !~ /^%/;
	    $named_var =~ s/^[\@%]// or die;

	    my @vars = map { $_ ? $_->name : () } @pos, $slurpy;
	    push @vars, "\%$named_var" if %named && !$slurpy;

	    if (!@vars) {
		# do nothing
	    }
	    elsif ($vars[-1] eq '@_') {
		pop @vars;
		if (!@vars) {
		    # do nothing
		}
		elsif (@vars <= 3) {
		    $code .= qq{    my $_ = shift;\n} for @vars;
		}
		else {
		    local $" = ', ';
		    $code .= qq{    my ( @vars ) = splice \@_, 0, @{[ scalar @vars ]};\n};
		}
	    }
	    else {
		local $" = ', ';
		$code .= qq{    my ( @vars ) = \@_;\n};
	    }

	    #
	    # If there are named parameters, go get 'em.
	    #

	    if (%named) {
		my @vars = sort keys %named;
		my @keys = map { /^\$(\w+)\z/ or die "BUG"; $1 } @vars;

		if (my @req_vars = grep { $named{$_}->has_trait('required') } @vars) {
		    my @req_keys = map { /^\$(\w+)\z/ } @req_vars;

		    my $croak = q{Perl6::Subs::_error "Required named parameter '$_' is missing"};
		    $code .= qq{    exists \$$named_var\E{\$_} or $croak for qw( @req_keys );\n};
		}

		## FIXME: insert Params::Validate call here
		$code .=
		  @vars == 1
		    ? qq{    my $vars[0] = delete \$$named_var\E{'$keys[0]'};\n}
		    : qq{    my ( @{[ join ', ', @vars ]} ) = delete \@$named_var\E{qw( @keys )};\n};

		# leftover named params are a bug unless the last param is *%slurpy
		$code .= qq{    Perl6::Subs::_error "Invalid named parameter(s) [\@{[ sort keys \%$named_var ]}]" if \%$named_var;\n}
		  unless $slurpy;
	    }
	}

	#
	# Check validity of non-slurpy parameters
	#

	for my $param (@pos,
		       map { $named{$_} } sort keys %named)
	{
	    my ($name, $type) = ($param->name, $param->type);

	    #use Data::Dumper;
	    #print Dumper $param->type;

	    my %ck;
	    for (my $t = $type; $t; $t = $t->base) {
		$ck{mustdef} ||= $t->mustdef;
		for my $attr (qw( qual where )) {
		    for ($t->$attr) {
			unshift @{ $ck{$attr} }, $_
			  if $_;
		    }
		}
	    }

	    if ($ck{qual} || $ck{mustdef}) {
		my $qual = join( ' and ',
				 $ck{mustdef} ? 'defined(_VAL_)' : (),
				 @{ $ck{qual} } );
		if (!$ck{mustdef})
		  { $qual = qq{ !defined(_VAL_) || ($qual) } }

		for ($qual) {
		    s{ \b _VAL_ \b }{$name}xg;
		    s/^\s+//;
		    s/\s+$//;
		}

		my $wanted = $type->name;
		if (!$wanted && ($type->where || $type->valid) && $type->base)
		  { $wanted = $type->base->name }
		$wanted = $wanted ? (($wanted =~ /^[aeiuo]/i ? "an" : "a") . " $wanted") : "valid";

		$code .= qq{    Perl6::Subs::_error 'Parameter $name is not $wanted' unless $qual;\n};
	    }

	    if ($ck{where}) {
		my $where = join ' && ', @{ $ck{where} };
		$code .= qq{    $where or Perl6::Subs::_error 'Parameter $name failed a where{} test' for $name;\n};
	    }
	}

	#
	# Let caller decide what to do with the code.
	#

	$code;
    }
}

#
# Perl6::Subs, again
#

sub _error {
    my $sub = (caller(1))[3];
    my ($c_file, $c_line) = (caller(2))[1, 2];

    my $msg = join '', @_;
    $msg .= " in call to $sub" unless $sub =~ /^\(/;
    $msg .= " at $c_file line $c_line";
    die "$msg\n";
}


#----------------------------------------------------------------
# Now filter using the above code
#

use Filter::Simple;

FILTER_ONLY
  executable =>
    sub {
	# FIXME: Use This
	my $ph = $Filter::Simple::placeholder;

	my $code = $_;
      SUB:
	while ($code =~ m{ # things to skip...
			   			   (?:
			       			       ^ [ \t]* \# .* $		# comments, we ass_u_me
			   			   )

			   			   |

			   			   # things not to skip
			   			   \b
			   			   (
			     			     (?: sub | ( method ) ) \b	# $2 is 'method' foo
			     			     (?: \s+ ( $word_rx ) )?
			     			     \s*
			   			   )
			   			   (?(2)  (?= \( | \{ | : | is \b | returns \b )
								| (?= \( [^\)]* \w ) )
			 			 }xmog)
	{
	    next SUB unless $1;

	    my $proto_pos = pos($code);
	    my $sub_pos = $proto_pos - length($1);
	    my $name = $3;

	    print "Perl6::Subs - trying sub decl at {{" . substr($code, $sub_pos, 40) . "}}\n"
	      if $DEBUG > 1;

	    my ($sub, $subtext) = Perl6::Subs::Sub->new_from_decl(substr($code, $sub_pos));

	    unless ($sub) {
		warn "Can't parse sub declaration for &$name\n" if $name;
		pos($code) = $proto_pos;
		next SUB;
	    }

	    #
	    # Replace the Perl 6 declaration with an equivalent Perl 5.
	    #

	    my $p5 = 'sub';
	    $p5 .= ' ' . $sub->name if defined $sub->name;

	    $p5 .= "\n" x ($subtext =~ tr/\n//);

	    while (my ($k, $v) = each %{ $sub->traits }) {
		# some traits are P6-specific
		next if $k eq 'returns';

		$p5 .= " :$k";
		$p5 .= "($v)" if defined $v;
	    }

	    $p5 .= ' ';

	    substr($code, $sub_pos, length($subtext)) = $p5;
	    pos($code) = $sub_pos + length($p5);

	    #
	    # If this is a sub definition, insert the initialization code.
	    #

	    if ($code =~ m{ \G \s* \{ }xgc) {

		my $init = $sub->init_code;

		if ($DEBUG)
		    { $init = "\n" . $init  }  # for indentation
		else
		    { $init =~ s/\n[ ]*/ /g }  # for line numbers

		my $init_pos = pos($code);
		substr($code, $init_pos, 0) = $init;
		pos($code) = $init_pos + length($init);
	    }

	    print "Perl6::Subs - resuming search for sub decls at {{" . substr($code, pos($code), 40) . "}}\n"
	      if $DEBUG > 1;
	}

	$_ = $code;
    },
  all =>
    sub {
	$DEBUG or return;
	my $sep = "=" x 72 . "\n";
	print $sep, $_, $sep;
    };

1;

__END__