File Coverage

blib/lib/Type/Library/Compiler.pm

Criterion	Covered	Total	%
statement	14	62	22.5
branch	0	14	0.0
condition	0	3	0.0
subroutine	5	14	35.7
pod	3	3	100.0
total	22	96	22.9

use 5.008001;
use strict;
use warnings;

package Type::Library::Compiler;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.005';

use Type::Library::Compiler::Mite -all;
use B ();

has types => (
	is => ro,
	isa => 'Map[NonEmptyStr,Object]',
	builder => sub { [] },
);

has pod => (
	is => rw,
	isa => 'Bool',
	coerce => true,
	default => true,
);

has destination_module => (
	is => ro,
	isa => 'NonEmptyStr',
	required => true,
);

has constraint_module => (
	is => ro,
	isa => 'NonEmptyStr',
	builder => sub {
		sprintf '%s::TypeConstraint', shift->destination_module;
	},
);

has destination_filename => (
	is => lazy,
	isa => 'NonEmptyStr',
	builder => sub {
		( my $module = shift->destination_module ) =~ s{::}{/}g;
		return sprintf 'lib/%s.pm', $module;
	},
);

sub compile_to_file {
	my $self = shift;

	open( my $fh, '>', $self->destination_filename )
		or croak( 'Could not open %s: %s', $self->destination_filename, $! );

	print { $fh } $self->compile_to_string;

	close( $fh )
		or croak( 'Could not close %s: %s', $self->destination_filename, $! );

	return;
}

sub compile_to_string {
	my $self = shift;

	my @type_names = sort keys %{ $self->types or {} };

	my $code = '';
	$code .= $self->_compile_header;
	$code .= $self->_compile_type( $self->types->{$_}, $_ ) for @type_names;
	$code .= $self->_compile_footer;

	if ( $self->pod ) {
		$code .= $self->_compile_pod_header;
		$code .= $self->_compile_pod_type( $self->types->{$_}, $_ ) for @type_names;
		$code .= $self->_compile_pod_footer;
	}

	return $code;
}

sub _compile_header {
	my $self = shift;

	return sprintf <<'CODE', $self->destination_module, $self->constraint_module, $self->destination_module;
use 5.008001;
use strict;
use warnings;

package %s;

use Exporter ();
use Carp qw( croak );

our @ISA = qw( Exporter );
our @EXPORT;
our @EXPORT_OK;
our %%EXPORT_TAGS = (
	is     => [],
	types  => [],
	assert => [],
);

BEGIN {
	package %s;
	our $LIBRARY = "%s";

	use overload (
		fallback => !!1,
		'|'      => 'union',
		bool     => sub { !! 1 },
		'""'     => sub { shift->[1] },
		'&{}'    => sub {
			my $self = shift;
			return sub { $self->assert_return( @_ ) };
		},
	);

	sub union {
		my @types = grep ref( $_ ), @_;
		my @codes = map $_->[0], @types;
		bless [
			sub { for ( @codes ) { return 1 if $_->(@_) } return 0 },
			join( '|', map $_->[1], @types ),
			\@types,
		], __PACKAGE__;
	}

	sub check {
		$_[0][0]->( $_[1] );
	}

	sub get_message {
		sprintf '%%s did not pass type constraint "%%s"',
			defined( $_[1] ) ? $_[1] : 'Undef',
			$_[0][1];
	}

	sub validate {
		$_[0][0]->( $_[1] )
			? undef
			: $_[0]->get_message( $_[1] );
	}

	sub assert_valid {
		$_[0][0]->( $_[1] )
			? 1
			: Carp::croak( $_[0]->get_message( $_[1] ) );
	}

	sub assert_return {
		$_[0][0]->( $_[1] )
			? $_[1]
			: Carp::croak( $_[0]->get_message( $_[1] ) );
	}

	sub to_TypeTiny {
		my ( $coderef, $name, $library, $origname ) = @{ +shift };
		if ( ref $library eq 'ARRAY' ) {
			require Type::Tiny::Union;
			return 'Type::Tiny::Union'->new(
				type_constraints => [ map $_->to_TypeTiny, @$library ],
			);
		}
		if ( $library ) {
			local $@;
			eval "require $library; 1" or die $@;
			my $type = $library->get_type( $origname );
			return $type if $type;
		}
		require Type::Tiny;
		return 'Type::Tiny'->new(
			name       => $name,
			constraint => sub { $coderef->( $_ ) },
			inlined    => sub { sprintf '%%s::is_%%s(%%s)', $LIBRARY, $name, pop }
		);
	}

	sub DOES {
		return 1 if $_[1] eq 'Type::API::Constraint';
		return 1 if $_[1] eq 'Type::Library::Compiler::TypeConstraint';
		shift->DOES( @_ );
	}
};

CODE
}

sub _compile_footer {
	my $self = shift;

	return <<'CODE';

1;
__END__