Skip to content

Commit

Permalink
Merge pull request #2946 from vrurg/problem-solving-3
Browse files Browse the repository at this point in the history 
Make subsets validate against their constraints same way as definites do.

See Raku/problem-solving#3 for details.
  • Loading branch information
@vrurg
vrurg committed Aug 16, 2019
2 parents 7e10626 + e9e234c commit ef9d135
Show file tree
Hide file tree
Showing 6 changed files with 82 additions and 15 deletions.
31 changes: 25 additions & 6 deletions src/Perl6/Actions.nqp
View file
Expand Up @@ -3367,7 +3367,8 @@ class Perl6::Actions is HLL::Actions does STDActions {
}
elsif $<initializer><sym> eq '.=' {
my $type := nqp::defined($*OFTYPE)
?? $*W.maybe-definite-how-base($*OFTYPE.ast) !! $*W.find_symbol: ['Any'];
?? $*W.maybe-nominalize($*OFTYPE.ast) !! $*W.find_symbol: ['Any'];
# ?? $*W.maybe-definite-how-base($*OFTYPE.ast) !! $*W.find_symbol: ['Any'];
my $dot_equals := $initast;
$dot_equals.unshift(QAST::WVal.new(:value($type)));
$dot_equals.returns($type);
Expand Down Expand Up @@ -3528,7 +3529,8 @@ class Perl6::Actions is HLL::Actions does STDActions {

$init-qast.unshift:
QAST::WVal.new: value => nqp::defined($*OFTYPE)
?? $*W.maybe-definite-how-base($*OFTYPE.ast) !! $*W.find_symbol: ['Mu']
?? $*W.maybe-nominalize($*OFTYPE.ast) !! $*W.find_symbol: ['Mu']
# ?? $*W.maybe-definite-how-base($*OFTYPE.ast) !! $*W.find_symbol: ['Mu']
if $<term_init><sym> eq '.=';

my $qast;
Expand Down Expand Up @@ -3563,9 +3565,25 @@ class Perl6::Actions is HLL::Actions does STDActions {
}

sub check_default_value_type($/, $descriptor, $bind_constraint, $what) {
unless nqp::istype($descriptor.default, $bind_constraint) {
$*W.throw($/, 'X::Syntax::Variable::MissingInitializer',
my $matches;
my $maybe := 0;
try {
$matches := nqp::istype($descriptor.default, $bind_constraint);
CATCH {
$maybe := 1;
my $pl := nqp::getpayload($_);
if nqp::istype($pl, $*W.find_symbol(['Exception'])) {
@*SORROWS.push($pl); # XXX Perhaps a method on Grammer similar to typed_sorry but which accepts an exception?
} else {
# Don't be too verbose, report only the actual line with the error.
$/.sorry(nqp::getmessage($_), "\n", nqp::shift(nqp::backtracestrings($_)));
}
}
}
unless $matches {
$/.typed_sorry('X::Syntax::Variable::MissingInitializer',
type => nqp::how($bind_constraint).name($bind_constraint),
:$maybe,
implicit => !nqp::istype($*OFTYPE, NQPMatch) || !$*OFTYPE<colonpairs> || $*OFTYPE<colonpairs> && !$*OFTYPE<colonpairs>.ast<D> && !$*OFTYPE<colonpairs>.ast<U>
?? ':' ~ $/.pragma($what) ~ ' by pragma'
!! 0
Expand Down Expand Up @@ -4083,7 +4101,7 @@ class Perl6::Actions is HLL::Actions does STDActions {
my $predeclared := $outer.symbol($name);
if $predeclared {
my $Routine := $*W.find_symbol(['Routine'], :setting-only);
unless nqp::istype( $predeclared<value>, $Routine)
unless nqp::istype($predeclared<value>, $Routine)
&& nqp::getattr_i($predeclared<value>, $Routine, '$!yada') {
$*W.throw($/, ['X', 'Redeclaration'],
symbol => ~$<deflongname>.ast,
Expand Down Expand Up @@ -5148,7 +5166,8 @@ class Perl6::Actions is HLL::Actions does STDActions {
my $Mu := $W.find_symbol: ['Mu'];
my $type := nqp::defined($*OFTYPE) ?? $*OFTYPE.ast !! $Mu;
if $<initializer><sym> eq '.=' {
my $init-type := $*W.maybe-definite-how-base: $type;
my $init-type := $*W.maybe-nominalize: $type;
# my $init-type := $*W.maybe-definite-how-base: $type;
$value_ast.unshift: QAST::WVal.new: :value($init-type);
$value_ast.returns: $init-type;
}
Expand Down
20 changes: 20 additions & 0 deletions src/Perl6/Metamodel/LanguageRevision.nqp
View file
@@ -0,0 +1,20 @@
# This role is for metaclasses with languare-revision dependent behavior.
role Perl6::Metamodel::LanguageRevision
does Perl6::Metamodel::Versioning
{
has $!lang_rev;

# The only allowed version format is 6.X
method set_language_version($obj, $ver) {
(nqp::iseq_i(nqp::chars($ver), 3) && nqp::eqat($ver, '6.', 0))
|| nqp::die("Language version must be a string in '6.<rev>' format, got `$ver`.");
self.set_ver($obj, $ver);
$!lang_rev := nqp::substr($ver, 2, 1);
}

method lang-rev-before($rev) {
nqp::iseq_i(nqp::chars($rev), 1)
|| nqp::die("Language revision must be a single letter, got `$rev`.");
nqp::iseq_i(nqp::cmp_s($!lang_rev, $rev), -1)
}
}
18 changes: 15 additions & 3 deletions src/Perl6/Metamodel/SubsetHOW.nqp
View file
Expand Up @@ -2,13 +2,16 @@ class Perl6::Metamodel::SubsetHOW
does Perl6::Metamodel::Naming
does Perl6::Metamodel::Documenting
does Perl6::Metamodel::Stashing
does Perl6::Metamodel::LanguageRevision
{
# The subset type or nominal type that we refine.
has $!refinee;

# The block implementing the refinement.
has $!refinement;

has $!pre-e-behavior;

my $archetypes := Perl6::Metamodel::Archetypes.new( :nominalizable(1) );
method archetypes() {
$archetypes
Expand All @@ -21,12 +24,16 @@ class Perl6::Metamodel::SubsetHOW
method BUILD(:$refinee, :$refinement) {
$!refinee := $refinee;
$!refinement := $refinement;
$!pre-e-behavior := self.lang-rev-before('e');
}

method new_type(:$name = '<anon>', :$refinee!, :$refinement!) {
my $metasubset := self.new(:refinee($refinee), :refinement($refinement));
my $type := nqp::settypehll(nqp::newtype($metasubset, 'Uninstantiable'), 'perl6');
$metasubset.set_name($type, $name);
# TODO This only works at compile time. To support run-time creation of subsets we need to find caller's CORE.
# Will be possible when nqp::p6callerrevision() is implemented.
$metasubset.set_language_version($metasubset, nqp::getcomp('perl6').language_version);
nqp::settypecheckmode($type, 2);
self.add_stash($type)
}
Expand Down Expand Up @@ -77,14 +84,19 @@ class Perl6::Metamodel::SubsetHOW

# Do check when we're on LHS of smartmatch (e.g. Even ~~ Int).
method type_check($obj, $checkee) {
nqp::hllboolfor(nqp::istrue($checkee.HOW =:= self) ||
nqp::istype($!refinee, $checkee), "perl6")
nqp::hllboolfor(
($!pre-e-behavior && nqp::istrue($checkee.HOW =:= self))
|| nqp::istype($!refinee, $checkee),
"perl6"
)
}

# Here we check the value itself (when on RHS on smartmatch).
method accepts_type($obj, $checkee) {
nqp::hllboolfor(
nqp::istype($checkee, $!refinee) &&
nqp::istrue($!refinement.ACCEPTS($checkee)), "perl6")
nqp::istrue($!refinement.ACCEPTS($checkee)),
"perl6"
)
}
}
21 changes: 17 additions & 4 deletions src/Perl6/World.nqp
View file
Expand Up @@ -1912,7 +1912,7 @@ class Perl6::World is HLL::World {
%info<bind_constraint> := self.parameterize_type_with_args($/,
%info<bind_constraint>, [$vtype], nqp::hash());
%info<value_type> := $vtype;
%info<default_value> := self.maybe-definite-how-base: $vtype;
%info<default_value> := self.maybe-nominalize: $vtype;
}
else {
%info<container_type> := %info<container_base>;
Expand Down Expand Up @@ -1980,7 +1980,7 @@ class Perl6::World is HLL::World {
%info<bind_constraint>, @value_type, nqp::hash());
%info<value_type> := @value_type[0];
%info<default_value>
:= self.maybe-definite-how-base: @value_type[0];
:= self.maybe-nominalize: @value_type[0];
}
else {
%info<container_type> := %info<container_base>;
Expand Down Expand Up @@ -2022,7 +2022,7 @@ class Perl6::World is HLL::World {
%info<bind_constraint> := @value_type[0];
%info<value_type> := @value_type[0];
%info<default_value>
:= self.maybe-definite-how-base: @value_type[0];
:= self.maybe-nominalize: @value_type[0];
}
else {
%info<bind_constraint> := self.find_symbol(['Mu'], :setting-only);
Expand All @@ -2033,14 +2033,27 @@ class Perl6::World is HLL::World {
}
%info
}
method maybe-definite-how-base ($v) {

method maybe-definite-how-base($v) {
# returns the value itself, unless it's a DefiniteHOW, in which case,
# it returns its base type. Behaviour available in 6.d and later only.
! $*W.lang-ver-before('d') && nqp::eqaddr($v.HOW,
$*W.find_symbol: ['Metamodel','DefiniteHOW'], :setting-only
) ?? $v.HOW.base_type: $v !! $v
}

method maybe-nominalize($v) {
# If type does LanguageRevision then check what language it was created with. Otherwise base decision on the
# current compiler.
if nqp::istype($v.HOW, $*W.find_symbol: ['Metamodel', 'LanguageRevision'])
?? $v.HOW.lang-rev-before('e')
!! $*W.lang-ver-before('e')
{
return self.maybe-definite-how-base($v);
}
$v.HOW.archetypes.nominalizable ?? $v.HOW.nominalize($v) !! $v
}

# Installs one of the magical lexicals ($_, $/ and $!). Uses a cache to
# avoid massive duplication of containers and container descriptors.
method install_lexical_magical($block, $name) {
Expand Down
6 changes: 4 additions & 2 deletions src/core/Exception.pm6
View file
Expand Up @@ -1802,10 +1802,12 @@ my class X::Syntax::Term::MissingInitializer does X::Syntax {
my class X::Syntax::Variable::MissingInitializer does X::Syntax {
has $.type;
has $.implicit;
has $.maybe;
method message {
my $modality = $.maybe ?? "may need" !! "requires";
$.implicit ??
"Variable definition of type $.type (implicit $.implicit) requires an initializer" !!
"Variable definition of type $.type requires an initializer"
"Variable definition of type $.type (implicit $.implicit) $modality an initializer" !!
"Variable definition of type $.type $modality an initializer"
}
}

Expand Down
1 change: 1 addition & 0 deletions tools/templates/common_bootstrap_sources
View file
Expand Up @@ -4,6 +4,7 @@ src/Perl6/Metamodel/Naming.nqp
src/Perl6/Metamodel/Documenting.nqp
src/Perl6/Metamodel/Stashing.nqp
src/Perl6/Metamodel/Versioning.nqp
src/Perl6/Metamodel/LanguageRevision.nqp
src/Perl6/Metamodel/TypePretense.nqp
src/Perl6/Metamodel/MethodDelegation.nqp
src/Perl6/Metamodel/BoolificationProtocol.nqp
Expand Down

0 comments on commit ef9d135

Please sign in to comment.