-
-
Notifications
You must be signed in to change notification settings - Fork 373
/
CurriedRoleHOW.pm
140 lines (127 loc) Β· 4.66 KB
/
CurriedRoleHOW.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
# Sometimes, we see references to roles that provide parameters but
# do not fully resolve them. For example, in:
#
# class C does R[T] { }
#
# We need to represent R[T], but we cannot yet fully specialize the
# role because we don't have the first parameter to hand. We may also
# run into the issue where we have things like:
#
# sub foo(R[T] $x) { ... }
# if $x ~~ R[T] { ... }
#
# Where we clearly want to talk about a partial parameterization of a
# role and actually want to do so in a way distinct from a particular
# instantiation of it. This meta-object represents those "partial types"
# as both a way to curry on your way to a full specialization, but also
# as a way to do type-checking or punning.
class Perl6::Metamodel::CurriedRoleHOW
does Perl6::Metamodel::RolePunning
does Perl6::Metamodel::TypePretense
{
has $!curried_role;
has @!pos_args;
has %!named_args;
my $archetypes_g := Perl6::Metamodel::Archetypes.new( :composable(1), :inheritalizable(1), :parametric(1), :generic(1) );
my $archetypes_ng := Perl6::Metamodel::Archetypes.new( :nominal(1), :composable(1), :inheritalizable(1), :parametric(1) );
method archetypes() {
if pir::repr_defined__IP(self) {
for @!pos_args {
if $_.HOW.archetypes.generic {
return $archetypes_g;
}
}
for %!named_args {
if $_.value.HOW.archetypes.generic {
return $archetypes_g;
}
}
}
$archetypes_ng
}
method new_type($curried_role, *@pos_args, *%named_args) {
my $meta := self.new(:curried_role($curried_role), :pos_args(@pos_args),
:named_args(%named_args));
my $type := pir::repr_type_object_for__PPS($meta, 'Uninstantiable');
pir::stable_set_type_check_mode__0PI($type, 2)
}
method instantiate_generic($obj, $type_env) {
my @new_pos;
my %new_named;
for @!pos_args {
@new_pos.push($_.HOW.archetypes.generic ??
$_.HOW.instantiate_generic($_, $type_env) !!
$_);
}
for %!named_args {
%new_named{$_.key} := $_.value.HOW.archetypes.generic ??
$_.value.HOW.instantiate_generic($_.value, $type_env) !!
$_.value;
}
self.new_type($!curried_role, |@new_pos, |%new_named)
}
method specialize($obj, $first_arg) {
$!curried_role.HOW.specialize($!curried_role, $first_arg,
|@!pos_args, |%!named_args);
}
method name($obj) {
$!curried_role.HOW.name($!curried_role)
}
method curried_role($obj) {
$!curried_role
}
method role_arguments($obj) {
@!pos_args
}
method roles($obj, :$transitive) {
$!curried_role.HOW.roles($obj, :transitive($transitive))
}
method role_typecheck_list($obj) {
$!curried_role.HOW.role_typecheck_list($obj)
}
method type_check($obj, $checkee) {
$!curried_role.HOW.type_check($!curried_role, $checkee)
}
method accepts_type($obj, $checkee) {
# First, we locate candidate curryings to check against. If
# the checkee is itself a curried role, it also goes in. Note
# that we only want those that have the same parametric role
# as us.
my @cands;
my $crdc := pir::perl6_decontainerize__PP($!curried_role);
if nqp::istype($checkee.HOW, self.WHAT) {
if pir::perl6_decontainerize__PP($checkee.HOW.curried_role($checkee)) =:= $crdc {
@cands.push($checkee);
}
}
for $checkee.HOW.role_typecheck_list($checkee) {
if nqp::istype($_.HOW, self.WHAT) && !$_.HOW.archetypes.generic {
if pir::perl6_decontainerize__PP($_.HOW.curried_role($_)) =:= $crdc {
@cands.push($_);
}
}
}
# Provided we have some candidates, check the arguments.
my $num_args := +@!pos_args;
if @cands {
for @cands {
my @try_args := $_.HOW.role_arguments($_);
if +@try_args == $num_args {
my $i := 0;
my $ok := 1;
while $i < +$num_args {
if !@!pos_args[$i].ACCEPTS(@try_args[$i]) {
$ok := 0;
$i := $num_args;
}
$i := $i + 1;
}
if $ok {
return 1;
}
}
}
}
0;
}
}