From d8e859d000fa658766266a45f99e58661dec7b0e Mon Sep 17 00:00:00 2001
From: Elizabeth Mattijsen <liz@wenzperl.nl>
Date: Tue, 28 Jan 2020 15:40:43 +0100
Subject: [PATCH] Make has Str $.a = 42 a compile time failure

- adapts default BUILDPLAN logic to perform some type tests
- adds X::TypeCheck::Attribute::Default class
- adds X::TypeCheck::Attribute::Default stub for setting compilation
---
 src/Perl6/Metamodel/BUILDPLAN.nqp | 37 ++++++++++++++++++++++++++++++-
 src/core.c/Exception.pm6          |  9 ++++++++
 src/core.c/core_prologue.pm6      |  1 +
 3 files changed, 46 insertions(+), 1 deletion(-)

diff --git a/src/Perl6/Metamodel/BUILDPLAN.nqp b/src/Perl6/Metamodel/BUILDPLAN.nqp
index f4c26fcb8a9..7cffb0ec9f2 100644
--- a/src/Perl6/Metamodel/BUILDPLAN.nqp
+++ b/src/Perl6/Metamodel/BUILDPLAN.nqp
@@ -124,12 +124,47 @@ role Perl6::Metamodel::BUILDPLAN {
         for @attrs {
             if nqp::can($_, 'build') {
                 my $default := $_.build;
-                my int $primspec := nqp::objprimspec($_.type);
+                my $type    := $_.type;
+                my int $primspec := nqp::objprimspec($type);
 #?if js
                 my int $is_oversized_int := $primspec == 4 || $primspec == 5;
                 $primspec := $is_oversized_int ?? 0 !! $primspec;
 #?endif
+
+                # compile check constants for correct type
                 if nqp::isconcrete($default) {
+                    if $default.HOW.name($default) eq 'Method' {
+                        # cannot typecheck code to be run later
+                    }
+                    elsif $primspec {
+                        # add typecheck on natives
+                    }
+                    elsif nqp::istype($default,$type) {
+                        # type checks out ok
+                    }
+                    elsif nqp::istype($type,$*W.find_symbol(["Associative"])) {
+                        # cannot do type checks on associatives
+                    }
+                    elsif nqp::istype(
+                      $type,
+                      my $Positional := $*W.find_symbol(["Positional"])
+                    ) && nqp::istype($default,$Positional.of) {
+                        # type of positional checks out ok
+                    }
+                    else {
+                        # constant value did not typecheck ok
+                        my $typecheck := $*W.find_symbol(["X","TypeCheck","Attribute","Default"]);
+                        if nqp::can($typecheck,'new') {
+                            $typecheck.new(
+                              operation => $_.is_bound ?? 'bind' !! 'assign',
+                              name      => $_.name,
+                              got       => $default,
+                              expected  => $type,
+                            ).throw;
+                        }
+                    }
+
+                    # all ok, push the action
                     nqp::push(@plan,[
                       ($primspec || !$_.is_bound ?? 4 + $primspec !! 14),
                       $obj,
diff --git a/src/core.c/Exception.pm6 b/src/core.c/Exception.pm6
index 3670c16fb8e..f875b995b7b 100644
--- a/src/core.c/Exception.pm6
+++ b/src/core.c/Exception.pm6
@@ -2367,6 +2367,15 @@ my class X::TypeCheck::Argument is X::TypeCheck {
     }
 }
 
+my class X::TypeCheck::Attribute::Default is X::TypeCheck does X::Comp {
+    has str $.name;
+    has $.operation;
+    method message {
+        self.priors() ~
+        "Can never $.operation default value $.gotn to attribute '$.name', it expects: $.expectedn"
+    }
+}
+
 my class X::TypeCheck::Splice is X::TypeCheck does X::Comp {
     has $.action;
     method message {
diff --git a/src/core.c/core_prologue.pm6 b/src/core.c/core_prologue.pm6
index 75985abda1f..17ad5f40ed2 100644
--- a/src/core.c/core_prologue.pm6
+++ b/src/core.c/core_prologue.pm6
@@ -26,6 +26,7 @@ my class WhateverCode { ... }
 my class X::Attribute::Required { ... }
 my class X::Numeric::Overflow { ... }
 my class X::Numeric::Underflow { ... }
+my class X::TypeCheck::Attribute::Default { ... }
 
 # Stub these or we can't use any sigil other than $.
 my role Positional { ... }