#!/usr/bin/perl
package Blondie::TypeSafe;
use strict;
use warnings;
use Blondie::ADTs;
use Blondie::Nodes;
sub new {
my $class = shift;
bless { }, $class;
}
sub typecheck {
my $self = shift;
my $runtime = shift;
my $prog = shift;
Blondie::TypeSafe::Flatten->new->reduce(
Blondie::TypeSafe::Annotator->new->annotate($runtime, $prog)
);
}
{
package Blondie::TypeSafe::Annotation;
use base qw/Blondie::Node::Map/;
use Carp qw/croak/;
sub fmap {
my $self = shift;
die "annotations are not fmappable, flatten first";
}
sub values {
my $self = shift;
croak "annotations are not eatable, flatten first";
}
sub type {
my $self = shift;
my $type = $self->SUPER::type;
# this method always returns the shallowest possible scalar value
# simplify [["Foo"]] into ["Foo"]
#$type = [$type]; # and "Foo" into ["Foo"]
while (ref $type and ref $type eq 'ARRAY' and @$type == 1){
$type = $type->[1];
}
return $type;
}
package Blondie::TypeSafe::Type;
use base qw/Blondie::Map/;
package Blondie::TypeSafe::Type::Bottom;
use base qw/Blondie::TypeSafe::Type/;
sub type { $_[0] }
package Blondie::TypeSafe::Type::Placeholder;
use base qw/Blondie::TypeSafe::Type/;
sub set {
my $self = shift;
my $type = shift;
warn Carp::longmess unless ref $type;
$self->{type} = $type->type;
bless $self, "Blondie::TypeSafe::Type::Std";
}
package Blondie::TypeSafe::Type::Std;
use base qw/Blondie::TypeSafe::Type/;
sub new {
my $class = shift;
my $type = shift;
$class->SUPER::new(type => $type);
}
}
{
package Blondie::TypeSafe::Flatten;
use base qw/Blondie::Reducer/;
use Scalar::Util ();
sub new { bless {}, shift }
sub reduce {
my $self = shift;
my $node = shift;
my $h = Devel::STDERR::Indent::indent();
warn "flattenning $node " . (eval { $node->struct_equiv } || "(not an object)");
Scalar::Util::blessed($node) ? $self->SUPER::reduce($node->struct_equiv) : $node;
}
}
{
package Blondie::TypeSafe::Annotator;
use base qw/Blondie::Reducer Blondie::Reducer::DynamicScoping Class::Accessor/;
use Scalar::Util ();
use B ();
use B::Flags ();
use String::Escape qw/qprintable/;
use Devel::STDERR::Indent qw/indent $STRING/;
$STRING = " ";
BEGIN { __PACKAGE__->mk_accessors(qw/runtime/) }
sub annotate {
my $self = shift;
my $runtime = shift;
my $prog = shift;
$self->{runtime} = $runtime;
$self->reduce($prog);
}
sub reduce {
my $self = shift;
my $h = indent;
my $node = shift;
warn "reducing " . qprintable($node) . "...";
my $res = $self->SUPER::reduce($node);
warn "reduce(" . (ref($node) ? $node : qprintable($node)) .") = $res (type = " . $self->display_type($res->type) . ")";
$res;
}
sub new {
my $class = shift;
bless {}, $class;
}
sub generic_reduce {
my $self = shift;
my $node = shift;
if (Scalar::Util::blessed($node) and $node->can("type")){
return Blondie::TypeSafe::Annotation->new(
type => $node->type,
struct_equiv => $node,
);
} else {
my $type = $self->guess_perl_type($node);
warn "type of " . qprintable($node) . " is $type";
return Blondie::TypeSafe::Annotation->new(
type => Blondie::TypeSafe::Type::Std->new($type),
struct_equiv => $node,
orig => $node,
);
}
}
sub guess_perl_type {
my $self = shift;
my $node = shift;
my $obj = B::svref_2object(ref($node) ? $node : \$node);
my $class = B::class($obj);
return $class unless $class eq "PVMG";
my $flags = $obj->flagspv;
return "IV" if $flags =~ "IOK";
return "PV" if $flags =~ "POK";
die "what type is $node ($flags)?";
}
sub reduce_sym {
my $self = shift;
my $sym = shift;
my $type = $self->find_dyn_sym($sym->val)->val;
warn "linking the symbol " . $sym->val . " to $type";
Blondie::TypeSafe::Annotation->new(
type => $type,
struct_equiv => $sym->fmap(sub { Blondie::TypeSafe::Annotation->new(struct_equiv => $_[0]) }),
);
}
sub reduce_val {
my $self = shift;
my $val = shift;
my $rval = $val->fmap(sub { $self->reduce($_[0]) });
my $sub = $rval->val;
Blondie::TypeSafe::Annotation->new(
type => $sub->type,
struct_equiv => $rval,
orig => $val,
);
}
sub reduce_app {
my $self = shift;
my $app = shift;
my $rapp = $app->fmap(sub { $self->reduce($_[0]) });
my ($thunk_val, @params) = $rapp->values;
my $thunk_type = $thunk_val->type;
my @context = ref $thunk_type eq "ARRAY" ? @$thunk_type : $thunk_type;
my $return_type = pop @context;
warn "Unifying paramter types with thunk prototype in $app";
my $i; my $unified_app = $rapp->fmap(sub {
my $node = shift;
return $node unless $i++; # skip the thunk
my $expected = shift @context;
#warn "## unifying " . $self->display_type($expected) . " with " . Data::Dumper::Dumper($node);
$self->unify_type($node, $expected);
});
return Blondie::TypeSafe::Annotation->new(
type => $return_type,
orig => $app,
struct_equiv => $unified_app,
);
}
sub simplify_type {
my $self = shift;
my $type = shift;
while (Scalar::Util::blessed($type) and !$type->isa("Blondie::TypeSafe::Type::Placeholder")){
my $new = $type->type;
return $type if ref $new and $new == $type;
$type = $new;
}
$type;
}
sub display_type {
my $self = shift;
my $type = $self->simplify_type(@_);
Scalar::Util::blessed($type)
? '<Placeholder>'
: (ref $type ? ("( " . join(" -> ", map { $self->display_type($_) } @{$type}) . " )") : $type);
}
sub unify_type {
my $self = shift;
my $node = shift;
my $expected_type = shift;
my $de_facto_type = $node->type;
warn "attempting to unify " . $node->struct_equiv . " whose type is " . $self->display_type($de_facto_type) . " with " . $self->display_type($expected_type);
warn Data::Dumper::Dumper($expected_type) unless defined $self->simplify_type($expected_type);
return $node if $self->types_eq($de_facto_type, $expected_type);
warn "types do not eq";
if ($self->is_placeholder($de_facto_type)) {
warn "filling " . $self->display_type($expected_type) . " for placeholder of " . Blondie::Emitter::Pretty->new->string(Blondie::TypeSafe::Flatten->new->reduce($node));
$de_facto_type->set($expected_type);
return $node;
} else {
warn "casting";
return $self->runtime->cast_node_type($node, $de_facto_type, $expected_type);
}
}
sub is_placeholder {
my $self = shift;
my $type = $self->simplify_type(shift);
Scalar::Util::blessed($type) and $type->isa("Blondie::TypeSafe::Type::Placeholder")
}
sub types_eq {
my $self = shift;
my $h = indent;
my $x = shift;
my $y = shift;
warn "comparing $x and $y";
if (Scalar::Util::blessed($x) and Scalar::Util::blessed($y)) {
die "baaah! expected type cannot be placeholder" if $y->isa("Blondie::TypeSafe::Type::Placeholder");
if (!$x->isa("Blondie::TypeSafe::Type::Placeholder")) {
return $self->types_eq($x->type, $y->type);
} else {
return undef;
}
} elsif (ref($x) and ref($y)) {
return unless @$x == @$y;
my @x = @$x;
my @y = @$y;
while (@x) {
return unless $self->types_eq(pop @x, pop @y)
}
return 1;
} elsif (!ref($x) and !ref($y)) {
return $x eq $y;
} else {
return;
}
}
sub reduce_thunk {
my $self = shift;
my $thunk = shift;
$self->enter_scope;
my $rthunk = $thunk->fmap(sub { $self->reduce($_[0]) });
$self->leave_scope;
my $child = $rthunk->val->struct_equiv;
if ($child->isa("Blondie::Seq")){
my @children_of_seq = $child->values; # the children of the seq child of the thunk
my $last = pop @children_of_seq;
my @params = grep { $_->struct_equiv->isa("Blondie::Param") } @children_of_seq;
return Blondie::TypeSafe::Annotation->new(
type => [ ( map { $_->accepts_type } @params ) => $last->type, ],
struct_equiv => $rthunk,
orig => $thunk,
);
} else {
return Blondie::TypeSafe::Annotation->new(
type => [ $child->type ],
struct_equiv => $rthunk,
orig => $thunk,
);
}
}
sub reduce_seq {
my $self = shift;
my $seq = shift;
my $rseq = $seq->fmap(sub { $self->reduce($_[0]) });
return Blondie::TypeSafe::Annotation->new(
type => ($rseq->values)[-1]->type,
struct_equiv => $rseq,
orig => $seq,
);
}
sub reduce_param {
my $self = shift;
my $param = shift;
$self->new_pad( $param->val, my $placeholder = Blondie::TypeSafe::Type::Placeholder->new );
my $rparam = $param->fmap(sub {
Blondie::TypeSafe::Annotation->new(
struct_equiv => $_[0],
type => Blondie::TypeSafe::Type::Bottom->new,
);
});
return Blondie::TypeSafe::Annotation->new(
type => Blondie::TypeSafe::Type::Bottom->new,
accepts_type => $placeholder,
struct_equiv => $rparam,
orig => $param,
);
}
sub can_reduce {
my $self = shift;
my $node = shift;
1;
}
}
__PACKAGE__;
__END__
=pod
=head1 NAME
Blondie::TypeSafe -
=head1 SYNOPSIS
use Blondie::TypeSafe;
=head1 DESCRIPTION
=cut