locked-types.pl

BEGIN { $ENV{EXTENDED_TESTING} = 0 };

use strict;
use warnings;
use Time::Limit;
use Test::Fatal;
use Test::TypeTiny;
use Test::More;

# Declared inline; don't try to load these thanks!
no thanks qw(
	Types::ReadOnly
	Type::Tiny::Wrapped
	Type::Tiny::Wrapper
	Type::Coercion::Wrapped
);

BEGIN {
	package Type::Tiny::Wrapper;
	use base 'Type::Tiny';
	use Scalar::Util 'weaken';
	
	sub new {
		my $class = shift;
		my $self = $class->SUPER::new(@_);
		Type::Tiny::_croak("Type::Tiny::Wrapper types must not have a constraint!")
			unless $self->_is_null_constraint;
		return $self;
	}
	
	sub wrap {
		my $self = shift;
		my $type = Types::TypeTiny::to_TypeTiny($_[0]);
		my $wrapped = bless($type->create_child_type => 'Type::Tiny::Wrapped');
		$wrapped->{wrapper}      = $self;
		$wrapped->{display_name} = sprintf('%s[%s]', $self->display_name, $type->display_name);
		$wrapped->{coercion}   ||= 'Type::Coercion::Wrapped'->new(
			type_constraint   => $wrapped,
			type_coercion_map => [ Types::Standard::Any(), q{ $_ } ],
		);
		bless($wrapped->{coercion} => 'Type::Coercion::Wrapped');
		return $wrapped;
	}
	
	my @FIELDS = qw/
		pre_check pre_coerce post_check post_coerce
		inlined_pre_check inlined_pre_coerce inlined_post_check inlined_post_coerce
	/;
	sub pre_check           { $_[0]{pre_check} }
	sub pre_coerce          { $_[0]{pre_coerce} }
	sub post_check          { $_[0]{post_check} }
	sub post_coerce         { $_[0]{post_coerce} }
	sub inlined_pre_check   { $_[0]{inlined_pre_check} }
	sub inlined_pre_coerce  { $_[0]{inlined_pre_coerce} }
	sub inlined_post_check  { $_[0]{inlined_post_check} }
	sub inlined_post_coerce { $_[0]{inlined_post_coerce} }
	
	sub child_type_class { +__PACKAGE__ }
	
	sub create_child_type {
		my $self = shift;
		$self->SUPER::create_child_type(
			( map {
				exists($self->{$_}) ? ($_ => $self->{$_}) : ()
			} @FIELDS ),
			@_,
		);
	}
	
	sub has_constraint_generator { 1 }
	
	sub constraint_generator {
		my $self = shift;
		weaken $self;
		return sub { $self->wrap(shift) };
	}
};

BEGIN {
	package Type::Coercion::Wrapped;
	use base 'Type::Coercion';
	use Scalar::Util 'weaken';
	
	sub _build_compiled_coercion {
		my $self = shift;
		
		my $type = $self->type_constraint;
		my $pre  = $type->pre_coerce;
		my $orig = $self->SUPER::_build_compiled_coercion(@_);
		my $post = $type->post_coerce;
		
		return $orig unless $pre || $post;
		
		weaken $type;
		return sub {
			local $_ = $_[0];
			$_ = $pre->($type, $_) if defined($pre);
			$_ = $orig->($_);
			$_ = $post->($type, $_) if defined($post);
			return $_;
		};
	}
	
	sub inline_coercion {
		...;
	}
	
	sub can_be_inlined {
		return 0;
		...;
	}
};

BEGIN {
	package Type::Tiny::Wrapped;
	use Scalar::Util 'weaken';
	use base 'Type::Tiny';
	
	sub wrapper             { $_[0]{wrapper} }
	sub wrapped             { $_[0]{parent} }
	sub pre_check           { $_[0]{wrapper}{pre_check} }
	sub pre_coerce          { $_[0]{wrapper}{pre_coerce} }
	sub post_check          { $_[0]{wrapper}{post_check} }
	sub post_coerce         { $_[0]{wrapper}{post_coerce} }
	sub inlined_pre_check   { $_[0]{wrapper}{inlined_pre_check} }
	sub inlined_pre_coerce  { $_[0]{wrapper}{inlined_pre_coerce} }
	sub inlined_post_check  { $_[0]{wrapper}{inlined_post_check} }
	sub inlined_post_coerce { $_[0]{wrapper}{inlined_post_coerce} }
	
	sub _build_compiled_check {
		my $self = shift;
		
		return Eval::TypeTiny::eval_closure(
			source      => sprintf('sub ($) { %s }', $self->inline_check('$_[0]')),
			description => sprintf("compiled check '%s'", $self),
		) if $self->can_be_inlined;
		
		my $pre  = $self->pre_check;
		my $orig = $self->wrapped->compiled_check(@_);
		my $post = $self->post_check;
		
		return $orig unless $pre || $post;
		
		weaken $self;
		return sub {
			local $_ = $_[0];
			return if defined($pre) && !$pre->($self, @_);
			return if !$orig->(@_);
			return if defined($post) && !$post->($self, @_);
			return !!1;
		};
	}
	
	sub _strict_check {
		my $self = shift;
		local $_ = $_[0];
		
		my $pre  = $self->pre_check;
		my $post = $self->post_check;
		
		return if defined($pre) && !$pre->($self, @_);
		return if !$self->wrapped->_strict_check(@_);
		return if defined($post) && !$post->($self, @_);
		
		return !!1;
	}
	
	sub is_subtype_of {
		my $self = shift;
		$self->wrapper->is_a_type_of(@_) or $self->SUPER::is_subtype_of(@_);
	}
	
	sub inline_check {
		my $self  = shift;
		local $_ = (my $var = $_[0]);
		
		Type::Tiny::_croak('Cannot inline type constraint check for "%s"', $self)
			unless $self->can_be_inlined;
		
		my @r;
		if (my $pre = $self->inlined_pre_check) {
			push @r, $pre->($self, $var);
		}
		push @r, $self->wrapped->inline_check($var);
		if (my $post = $self->inlined_post_check) {
			push @r, $post->($self, $var);
		}
		
		my $r = join " && " => map { /[;{}]/ ? "do { $_ }" : "($_)" } @r;
		return @r==1 ? $r : "($r)";
	}
	
	sub can_be_inlined {
		my $self = shift;
		return if $self->pre_check && ! $self->inlined_pre_check;
		return if $self->post_check && ! $self->inlined_post_check;
		return $self->wrapped->can_be_inlined;
	}
};

BEGIN {
	package Types::ReadOnly;
	use Types::Standard qw( Any Dict );
	use Type::Utils;
	use Type::Library -base, -declare => qw(Locked);
	
	use Scalar::Util qw( reftype );
	use Hash::Util qw( hashref_locked lock_ref_keys legal_ref_keys );
	
	declare Locked,
		bless     => 'Type::Tiny::Wrapper',
		pre_check => sub {
			return unless reftype($_) eq 'HASH';
			return unless hashref_locked($_);
			
			my $type    = shift;
			my $wrapped = $type->wrapped;
			my ($dict) = grep {
				$_->is_parameterized
					and $_->has_parent
					and $_->parent->strictly_equals(Dict)
			} $wrapped, $wrapped->parents;
			if ($dict) {
				my %constraints = @{ $dict->parameters };
				if (%constraints) {
					my $keys  = join "*#*", sort { $a cmp $b } keys %constraints;
					my $legal = join "*#*", sort { $a cmp $b } legal_ref_keys($_);
					return if $keys ne $legal;
				}
			}
			return !!1;
		},
		inlined_pre_check => sub {
			my @r;
			push @r, qq[Scalar::Util::reftype($_) eq 'HASH'];
			push @r, qq[Hash::Util::hashref_locked($_)];
			
			my $type    = $_[0];
			my $wrapped = $type->wrapped;
			my ($dict) = grep {
				$_->is_parameterized
					and $_->has_parent
					and $_->parent->strictly_equals(Dict)
			} $wrapped, $wrapped->parents;
			if ($dict) {
				my %constraints = @{ $dict->parameters };
				if (%constraints) {
					require B;
					my $keys = join "*#*", sort { $a cmp $b } keys %constraints;
					push @r, B::perlstring($keys).qq[ eq join "*#*", sort { \$a cmp \$b } Hash::Util::legal_ref_keys($_)];
				}
			}
			return @r;
		},
		post_coerce => sub {
			my $type    = shift;
			my $wrapped = $type->wrapped;
			my ($dict) = grep {
				$_->is_parameterized
					and $_->has_parent
					and $_->parent->strictly_equals(Dict)
			} $wrapped, $wrapped->parents;
			if ($dict) {
				my %constraints = @{ $dict->parameters };
				if (my @keys = keys %constraints) {
					lock_ref_keys($_, @keys);
					return $_;
				}
			}
			lock_ref_keys($_);
			return $_;
		},
	;
};

use Data::Dumper;
use Types::Standard -types;
use Types::ReadOnly -types;
use Hash::Util qw( hashref_locked lock_ref_keys legal_ref_keys );

my $my_hash = HashRef[ Undef ];
my $my_lock = Locked[ $my_hash ];
my $foo     = $my_lock->create_child_type(name => 'Foo');

isa_ok(Locked, 'Type::Tiny::Wrapper');
isa_ok($my_lock, 'Type::Tiny::Wrapped');

ok( $my_lock->is_a_type_of(Locked), '$my_lock->is_a_type_of(Locked)');
ok( $my_lock->is_a_type_of($my_hash), '$my_lock->is_a_type_of($my_hash)');
ok(!$my_lock->is_strictly_a_type_of(Locked), '!$my_lock->is_strictly_a_type_of(Locked)');
ok( $my_lock->is_strictly_a_type_of($my_hash), '$my_lock->is_strictly_a_type_of($my_hash)');

TODO: {
	local $TODO = 'make is_a_type_of/is_subtype_of work via recursion!!';
	ok( $foo->is_a_type_of(Locked), '$foo->is_a_type_of(Locked)');
};
ok( $foo->is_a_type_of($my_hash), '$foo->is_a_type_of($my_hash)');
ok(!$foo->is_strictly_a_type_of(Locked), '!$foo->is_strictly_a_type_of(Locked)');
ok( $foo->is_strictly_a_type_of($my_hash), '$foo->is_strictly_a_type_of($my_hash)');

my $hash1 = { foo => undef };
my $hash2 = { foo => undef };  lock_ref_keys($hash2);
my $hash3 = { foo => "xxx" };  lock_ref_keys($hash3);

like(
	exception { my $bar = $hash2->{bar} },
	qr{^Attempt to access disallowed key 'bar' in a restricted hash},
	'hashes can be locked',
);

should_pass($hash1, $my_hash);
should_pass($hash2, $my_hash);
should_fail($hash3, $my_hash);
should_fail($hash1, $my_lock);
should_pass($hash2, $my_lock);
should_fail($hash3, $my_lock);

{
	local $TODO = 'make _strict_check work via recursion!!';
	should_fail($hash1, $foo);
	should_pass($hash2, $foo);
	should_fail($hash3, $foo);
};

my $my_dict     = Dict[ foo => Int, bar => Optional[Int] ];
my $locked_dict = Locked[ $my_dict ];

my $dict1 = { foo => 1 };  lock_ref_keys($dict1, qw/foo/);
my $dict2 = { foo => 1 };  lock_ref_keys($dict2, qw/foo bar/);
my $dict3 = { foo => 1 };  lock_ref_keys($dict3, qw/foo bar baz/);

should_pass($_, $my_dict) for $dict1, $dict2, $dict3;
should_fail($dict1, $locked_dict);
should_pass($dict2, $locked_dict);
should_fail($dict3, $locked_dict);

my $new = $locked_dict->coerce({ foo => 42 });
ok( hashref_locked($new), 'coercion locks keys' );
is_deeply(
	[ sort { $a cmp $b } legal_ref_keys($new) ],
	[ qw/ bar foo / ],
	'coercion locks the correct keys'
);

done_testing;