signature_for now handles return types

lib/Type/Params.pm

@@ -131,6 +131,8 @@ sub signature_for {
 		signature_for( $_, %opts ) for @$function;
 		return;
 	}
+
+	$opts{_is_signature_for} = 1;
 
 	my $fullname = ( $function =~ /::/ ) ? $function : "$package\::$function";
 	$opts{package}   ||= $package;
@@ -1053,6 +1055,39 @@ Or as a shortcut:
 It is doubtful you want to use any of these options, except
 C<< bless => false >>.
 
+=head4 C<< returns >> B<TypeTiny>, C<< returns_scalar >> B<TypeTiny>, and C<< returns_list >> B<TypeTiny>
+
+These can be used to specify the type returned by your function.
+
+ sub round_number {
+   state $sig = signature(
+     pos          => [ Num ],
+     returns      => Int,
+   );
+   my ( $num ) = $sig->( @_ );
+   return int( $num );
+ }
+
+If your function returns different types in scalar and list context,
+you can use C<returns_scalar> and C<returns_list> to indicate separate
+return types in different contexts.
+
+ state $sig = signature(
+   pos             => [ Int, Int ],
+   returns_scalar  => Int,
+   returns_list    => Tuple[ Int, Int, Int ],
+ );
+
+The C<returns_list> constraint is defined using an B<ArrayRef>-like or
+B<HashRef>-like type constraint even though it's returning a list, not
+a single reference.
+
+B<Note:> because signature checks happen early before the rest of your
+function executes, the C<returns>, C<returns_scalar>, and C<returns_list>
+options are considered I<advisorary> and I<for documentation> and are
+not actually checked! However, the C<signature_for> keyword, which wraps
+your entire sub, is able to check them.
+
 =head3 Parameter Options
 
 In the parameter lists for the C<positional> and C<named> signature
@@ -1446,6 +1481,12 @@ of C<want_source>, C<want_details>, and C<goto_next> which will not work.
 (If using the C<multiple> option, then C<goto_next> is still supported in
 the I<nested> signatures.)
 
+The C<returns>, C<returns_scalar>, and C<returns_list> options
+are actually checked instead of just being advisorary. (Because this
+means that the signature will need to run code *after* your original
+function has run, it means the signature will be visible on the caller
+stack from within your function.)
+
 If you are providing a signature for a sub in another package, then
 C<< signature_for "Some::Package::some_sub" => ( ... ) >> will work,
 as will C<< signature_for some_sub => ( package => "Some::Package", ... ) >>.

lib/Type/Params/Signature.pm

@@ -40,7 +40,7 @@ sub _new_code_accumulator {
 
 sub new {
 	my $class = shift;
-	my %self  = @_ == 1 ? %{$_[0]} : @_;
+	my %self = @_ == 1 ? %{$_[0]} : @_;
 	my $self = bless \%self, $class;
 	$self->{parameters}   ||= [];
 	$self->{class_prefix} ||= 'Type::Params::OO::Klass';
@@ -74,6 +74,21 @@ sub new {
 			);
 		}
 
+		if ( my $r = delete $self->{returns} ) {
+			$self->{returns_scalar} ||= $r;
+			$self->{returns_list}   ||= ArrayRef->of( $r );
+		}
+
+		for my $attr ( qw/ returns_scalar returns_list / ) {
+			if ( is_Str $self->{$attr} ) {
+				require Type::Utils;
+				$self->{$attr} = Type::Utils::dwim_type( $self->{$attr}, $self->{package} ? ( for => $self->{package} ) : () );
+			}
+			elsif ( exists $self->{$attr} ) {
+				$self->{$attr} = to_TypeTiny( $self->{$attr} );
+			}
+		}
+
 		if ( defined $self->{bless} and $self->{bless} eq 1 and not $self->{named_to_list} ) {
 			my $klass_key     = $self->_klass_key;
 			$self->{bless}    = ( $klass_cache{$klass_key} ||= sprintf( '%s%d', $self->{class_prefix}, ++$klass_id ) );
@@ -279,6 +294,8 @@ sub class         { $_[0]{class} }
 sub constructor   { $_[0]{constructor} }
 sub named_to_list { $_[0]{named_to_list} }
 sub oo_trace      { $_[0]{oo_trace} }
+sub returns_scalar{ $_[0]{returns_scalar} }  sub has_returns_scalar{ exists $_[0]{returns_scalar} }
+sub returns_list  { $_[0]{returns_list} }    sub has_returns_list  { exists $_[0]{returns_list} }
 
 sub method_invocant { $_[0]{method_invocant} = defined( $_[0]{method_invocant} ) ? $_[0]{method_invocant} : 'undef' }
 
@@ -703,6 +720,13 @@ sub _coderef_extra_names {
 sub _coderef_end {
 	my ( $self, $coderef ) = ( shift, @_ );
 
+	if ( $self->{_is_signature_for} and $self->goto_next ) {
+		$coderef->add_variable( '$return_check_for_scalar', \ $self->returns_scalar->compiled_check )
+			if $self->has_returns_scalar;
+		$coderef->add_variable( '$return_check_for_list', \ $self->returns_list->compiled_check )
+			if $self->has_returns_list;
+	}
+
 	if ( $self->bless and $self->oo_trace ) {
 		my $package = $self->package;
 		my $subname = $self->subname;
@@ -772,7 +796,11 @@ sub _make_return_expression {
 	my $list = join q{, }, $self->_make_return_list;
 
 	if ( $self->goto_next ) {
-		if ( $list eq '@_' ) {
+		if ( $self->{_is_signature_for} and ( $self->has_returns_list or $self->has_returns_scalar ) ) {
+			my $call = sprintf '$__NEXT__->( %s )', $list;
+			return $self->_make_typed_return_expression( $call );
+		}
+		elsif ( $list eq '@_' ) {
 			return sprintf 'goto( $__NEXT__ )';
 		}
 		else {
@@ -788,6 +816,62 @@ sub _make_return_expression {
 	}
 }
 
+sub _make_typed_return_expression {
+	my ( $self, $expr ) = @_;
+
+	return sprintf 'wantarray ? %s : defined( wantarray ) ? %s : do { %s; undef; }',
+		$self->has_returns_list ? $self->_make_typed_list_return_expression( $expr, $self->returns_list ) : $expr,
+		$self->has_returns_scalar ? $self->_make_typed_scalar_return_expression( $expr, $self->returns_scalar ) : $expr,
+		$expr;
+}
+
+sub _make_typed_scalar_return_expression {
+	my ( $self, $expr, $constraint ) = @_;
+
+	if ( $constraint->{uniq} == Any->{uniq} ) {
+		return $expr;
+	}
+	elsif ( $constraint->can_be_inlined ) {
+		return sprintf 'do { my $__RETURN__ = %s; ( %s ) ? $__RETURN__ : %s }',
+			$expr,
+			$constraint->inline_check( '$__RETURN__' ),
+			$self->_make_constraint_fail( constraint => $constraint, varname => '$__RETURN__' );
+	}
+	else {
+		return sprintf 'do { my $__RETURN__ = %s; $return_check_for_scalar->( $__RETURN__ ) ? $__RETURN__ : %s }',
+			$expr,
+			$self->_make_constraint_fail( constraint => $constraint, varname => '$__RETURN__' );
+	}
+}
+
+sub _make_typed_list_return_expression {
+	my ( $self, $expr, $constraint ) = @_;
+
+	my $slurp_into = Slurpy->of( $constraint )->my_slurp_into;
+	my $varname = $slurp_into eq 'HASH' ? '%__RETURN__' : '@__RETURN__';
+
+	if ( $constraint->{uniq} == Any->{uniq} ) {
+		return $expr;
+	}
+	elsif ( $constraint->can_be_inlined ) {
+		return sprintf 'do { my %s = %s; my $__RETURN__ = \ %s; ( %s ) ? %s : %s }',
+			$varname,
+			$expr,
+			$varname,
+			$constraint->inline_check( '$__RETURN__' ),
+			$varname,
+			$self->_make_constraint_fail( constraint => $constraint, varname => '$__RETURN__', display_var => "\\$varname" );
+	}
+	else {
+		return sprintf 'do { my %s = %s; my $__RETURN__ = \ %s; $return_check_for_list->( $__RETURN__ ) ? %s : %s }',
+			$varname,
+			$expr,
+			$varname,
+			$varname,
+			$self->_make_constraint_fail( constraint => $constraint, varname => '$__RETURN__', display_var => "\\$varname" );
+	}
+}
+
 sub _make_general_fail {
 	my ( $self, %args ) = ( shift, @_ );
 

t/20-modules/Type-Params/v2-returns.t

@@ -0,0 +1,92 @@
+=pod
+
+=encoding utf-8
+
+=head1 PURPOSE
+
+Check that Type::Params v2 supports return typrs.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>[email protected]E<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2024 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut
+
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Type::Params -sigs;
+use Types::Common -types;
+
+subtest "Simple return type" => sub {
+	signature_for test1 => (
+		pos     => [ Num, Num ],
+		returns => Int,
+	);
+
+	sub test1 {
+		my ( $x, $y ) = @_;
+		return $x + $y;
+	}
+
+	is( scalar( test1( 2, 3 ) ), 5, 'happy path, scalar context' );
+	is_deeply( [ test1( 2, 3 ) ], [ 5 ], 'happy path, list context' );
+	is( do { test1( 2, 3 ); 1 }, 1, 'happy path, void context' );
+
+	ok(  exception { scalar( test1( 2.1, 3 ) ) }, 'bad path, scalar context' );
+	ok(  exception { [ test1( 2.1, 3 ) ] }, 'bad path, list context' );
+	ok( !exception { do { test1( 2.1, 3 ); 1 } }, 'bad path, void context' );
+};
+
+subtest "Non-inlinable return type" => sub {
+	signature_for test2 => (
+		pos     => [ Num, Num ],
+		returns => Int->where(sub { 1 }),
+	);
+
+	sub test2 {
+		my ( $x, $y ) = @_;
+		return $x + $y;
+	}
+
+	is( scalar( test2( 2, 3 ) ), 5, 'happy path, scalar context' );
+	is_deeply( [ test2( 2, 3 ) ], [ 5 ], 'happy path, list context' );
+	is( do { test2( 2, 3 ); 1 }, 1, 'happy path, void context' );
+
+	ok(  exception { scalar( test2( 2.1, 3 ) ) }, 'bad path, scalar context' );
+	ok(  exception { [ test2( 2.1, 3 ) ] }, 'bad path, list context' );
+	ok( !exception { do { test2( 2.1, 3 ); 1 } }, 'bad path, void context' );
+};
+
+subtest "Per-context return types" => sub {
+	signature_for test3 => (
+		pos            => [ Num ],
+		returns_scalar => Int,
+		returns_list   => HashRef[ Int ],
+	);
+
+	sub test3 {
+		my ( $x ) = @_;
+		wantarray ? ( foo => $x ) : $x;
+	}
+
+	is( scalar( test3( 5 ) ), 5, 'happy path, scalar context' );
+	is_deeply( [ test3( 5 ) ], [ foo => 5 ], 'happy path, list context' );
+	is( do { test3( 5 ); 1 }, 1, 'happy path, void context' );
+
+	ok(  exception { scalar( test3( 5.1 ) ) }, 'bad path, scalar context' );
+	ok(  exception { [ test3( 5.1 ) ] }, 'bad path, list context' );
+	ok( !exception { do { test3( 5.1 ); 1 } }, 'bad path, void context' );
+};
+
+done_testing;