diff --git a/lib/F/Function.pm b/lib/F/Function.pm index ce69d8bf..d99d4276 100644 --- a/lib/F/Function.pm +++ b/lib/F/Function.pm @@ -38,6 +38,7 @@ sub desc { return "function '$$func{name}'"; } +# all WantNeeds which belong to this function sub arguments { my $func = shift; @@ -53,6 +54,7 @@ sub arguments { return @wn; } +# all Returns and ReturnPairs which belong to this function sub returns { my $func = shift; diff --git a/lib/F/Regex.pm b/lib/F/Regex.pm index 724c2135..714154e9 100644 --- a/lib/F/Regex.pm +++ b/lib/F/Regex.pm @@ -30,7 +30,7 @@ sub desc { my $first = length $rgx->{value} > 13 ? substr($rgx->{value}, 0, 10).'...' : $rgx->{value}; - return "Regex /$first/"; + return "regex /$first/"; } sub perl_fmt { diff --git a/lib/Ferret/Core/FF.pm b/lib/Ferret/Core/FF.pm index 7ab66596..0e819d15 100644 --- a/lib/Ferret/Core/FF.pm +++ b/lib/Ferret/Core/FF.pm @@ -454,7 +454,8 @@ sub method_event_def { # type definitions. sub typedef { my ($scope, $scope_or_class, $type_name, $code, $lazy) = @_; - my $typedef = sub { + my $f = $scope->f; + my $create_typedef = sub { # this sub returns a function which returns Ferret true if # a method requirement is satisfied. @@ -530,21 +531,30 @@ sub typedef { }; + # create a prototype. + my $proto = Ferret::Prototype->new($f) if $lazy; + # create a function. my $func = ffunction(sub { my (undef, $args) = @_; my $obj = $args->{obj}; + + # already an instance of this type. + return $obj if $proto && $obj->has_parent($proto); + + # compute the result and make it an instance of this type. my $res = $code->($obj, $create_can, $transform); + $res->add_parent($proto) if $proto; + return $res || Ferret::undefined; }, $type_name, '$obj'); + $func->set_property(proto => $proto) if $proto; $func->{is_typedef} = 1; return $func; }; - $scope_or_class->set_property($type_name => - $lazy ? [ $typedef ] : $typedef->() - ); # TODO: pos + $scope_or_class->set_property($type_name => $create_typedef->()); } sub typedef_check { diff --git a/lib/Ferret/Object.pm b/lib/Ferret/Object.pm index b5c33524..0e6c65ad 100644 --- a/lib/Ferret/Object.pm +++ b/lib/Ferret/Object.pm @@ -489,7 +489,7 @@ sub _uniq { sub parent_classes { my ($obj, @classes) = shift; foreach my $parent ($obj->parents) { - next unless $parent->{is_proto}; + next unless $parent->{is_proto} && $parent->{proto_class}; push @classes, $parent->{proto_class}; } return @classes;