File Coverage

blib/lib/Devel/TypeCheck/Environment.pm
Criterion Covered Total %
statement 30 104 28.8
branch 0 28 0.0
condition 0 18 0.0
subroutine 10 27 37.0
pod 15 17 88.2
total 55 194 28.3


line stmt bran cond sub pod time code
1             package Devel::TypeCheck::Environment;
2              
3 1     1   6456 use strict;
  1         3  
  1         53  
4              
5 1     1   7 use Carp;
  1         2  
  1         91  
6              
7 1     1   1267 use Devel::TypeCheck::Type;
  1         4  
  1         81  
8 1     1   796 use Devel::TypeCheck::Type::Var;
  1         3  
  1         64  
9 1     1   4815 use Devel::TypeCheck::Type::Mu;
  1         3  
  1         51  
10 1     1   642 use Devel::TypeCheck::Type::Eta;
  1         4  
  1         60  
11 1     1   3869 use Devel::TypeCheck::Type::Kappa;
  1         3  
  1         54  
12 1     1   3636 use Devel::TypeCheck::Type::Rho;
  1         4  
  1         53  
13 1     1   620 use Devel::TypeCheck::Type::Nu;
  1         3  
  1         51  
14 1     1   7 use Devel::TypeCheck::Util;
  1         2  
  1         1511  
15              
16             =head1 NAME
17              
18             Devel::TypeCheck::Environment - class for managing the type
19             environment in B::TypeCheck
20              
21             =head1 SYNOPSIS
22              
23             Objects of this type are instantiated with the C<> method.
24              
25             =head1 DESCRIPTION
26              
27             The data structure is essentially a linked list from Mu at the head of
28             the list to terminal or variable types at the end. Thus, most of the
29             functions defined here support that by relaying the request to the
30             subtype member (the next link in the linked list) instead of actually
31             doing anything themselves.
32              
33             =over 4
34              
35             =cut
36              
37             =item B
38              
39             Create a new type environment.
40              
41             =cut
42             sub new {
43 0     0 1   my ($name) = @_;
44 0           my $this = {};
45              
46 0           $this->{'typeVars'} = [];
47              
48 0           return bless($this, $name);
49             }
50              
51             =item B
52              
53             Create a new type variable in the context of the environment. This
54             is so we can find unbound type variables later.
55              
56             =cut
57             sub fresh {
58 0     0 1   my ($this) = @_;
59              
60 0           my $id = $#{$this->{'typeVars'}} + 1;
  0            
61 0           my $var = Devel::TypeCheck::Type::Var->new($id);
62              
63 0           push(@{$this->{'typeVars'}}, $var);
  0            
64              
65 0           return $var;
66             }
67              
68             =item B
69              
70             Return a fully qualified incomplete Kappa instance
71              
72             =cut
73              
74             sub freshKappa {
75 0     0 0   my ($this) = @_;
76 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Kappa->new($this->fresh()));
77             }
78              
79             =item B
80              
81             Return a fully qualified incomplete Eta instance
82              
83             =cut
84             sub freshEta {
85 0     0 1   my ($this) = @_;
86 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Eta->new($this->freshKappa, $this->genOmicron, $this->genChi, $this->freshZeta));
87             }
88              
89             =item B
90              
91             Return a fully qualified incomplete Nu instance
92              
93             =cut
94             sub freshNu {
95 0     0 1   my ($this) = @_;
96 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Kappa->new(Devel::TypeCheck::Type::Upsilon->new(Devel::TypeCheck::Type::Nu->new($this->fresh()))));
97             }
98              
99             =item B
100              
101             Return a fully qualified incomplete Rho instance
102              
103             =cut
104             sub freshRho {
105 0     0 1   my ($this) = @_;
106 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Kappa->new(Devel::TypeCheck::Type::Rho->new($this->fresh())));
107             }
108              
109             =item B
110              
111             Return a fuly qualified incomplete Upsilon instance
112              
113             =cut
114             sub freshUpsilon {
115 0     0 1   my ($this) = @_;
116 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Kappa->new(Devel::TypeCheck::Type::Upsilon->new($this->fresh())));
117             }
118              
119             =item B
120              
121             Return a fully qualified incomplete Zeta instance
122              
123             =cut
124             sub freshZeta {
125 0     0 1   my ($this) = @_;
126 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Zeta->new($this->genOmicron, $this->fresh));
127             }
128              
129             =item B
130              
131             Encapsulate something in a fully qualified reference
132              
133             =cut
134             sub genRho {
135 0     0 1   my ($this, $referent) = @_;
136 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Kappa->new(Devel::TypeCheck::Type::Rho->new($referent)));
137             }
138              
139             =item B
140              
141             Encapsulate something in a fully qualified glob
142              
143             =cut
144             sub genEta {
145 0     0 1   my ($this, $referent) = @_;
146 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Eta->new($referent));
147             }
148              
149             =item B
150              
151             Generate a fully quialified incomplete Omicron instance.
152              
153             =item B($subtype)
154              
155             Generate a fully qualified Omicron instance with the given type as the homogeneous type.
156              
157             =cut
158              
159             sub genOmicron {
160 0     0 1   my ($this, $subtype) = @_;
161 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Omicron->new($subtype));
162             }
163              
164             =item B(@types)
165              
166             Create a new tuple-type list given a list of types.
167              
168             =cut
169              
170             sub genOmicronTuple {
171 0     0 1   my ($this, @ary) = @_;
172              
173 0           my $fresh = $this->genOmicron();
174              
175 0           $fresh->subtype->{'ref'}->{'ary'} = \@ary;
176              
177 0           return $fresh;
178             }
179              
180             =item B
181              
182             Generate a fully qualified incomplete Chi instance
183              
184             =item B($subtype)
185              
186             Generate a homogeneous Chi type with the given subtype as the homogeneous type.
187              
188             =cut
189              
190             sub genChi {
191 0     0 1   my ($this, $subtype) = @_;
192 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Chi->new($subtype));
193             }
194              
195             =item B($params, $return)
196              
197             Generate a Zeta type with the given params and return value.
198              
199             =cut
200             sub genZeta {
201 0     0 1   my ($this, $params, $return) = @_;
202 0           return Devel::TypeCheck::Type::Mu->new(Devel::TypeCheck::Type::Zeta->new($params, $return));
203             }
204              
205             # Union two types, as per union-find data structure
206             sub union {
207 0     0 0   my ($this, $t1, $t2) = @_;
208            
209             # Union two type variables
210 0 0 0       if ($t1->type == Devel::TypeCheck::Type::VAR() &&
    0 0        
    0 0        
211             $t2->type == Devel::TypeCheck::Type::VAR()) {
212 0 0         if ($t1->{'rank'} > $t2->{'rank'}) {
    0          
213 0           $t2->{'parent'} = $t1;
214 0           return $t1;
215             } elsif ($t1->{'rank'} < $t1->{'rank'}) {
216 0           $t1->{'parent'} = $t2;
217 0           return $t2;
218             } else {
219             # $t1->{'rank'} == $t2->{'rank'}
220 0 0         if ($t1 != $t2) {
221 0           $t1->{'parent'} = $t2;
222 0           $t2->{'rank'}++;
223             }
224              
225 0           return $t2;
226             }
227            
228             # The next two clauses handle the union of a type variable with a
229             # concrete type
230             } elsif ($t1->type == Devel::TypeCheck::Type::VAR() &&
231             $t2->type != Devel::TypeCheck::Type::VAR()) {
232 0           $t1->{'parent'} = $t2;
233 0           return $t2;
234             } elsif ($t1->type != Devel::TypeCheck::Type::VAR() &&
235             $t2->type == Devel::TypeCheck::Type::VAR()) {
236 0           $t2->{'parent'} = $t1;
237 0           return $t1;
238              
239             # There cannot be a union between two concrete types. If two
240             # types contain types that can be unioned, this happens in unify.
241             } else {
242             # $t1->type != VAR && $t2->type != VAR
243 0           return undef;
244             }
245             }
246              
247             =item B($t1, $t2)
248              
249             Unify the two given types. If unsuccessful, this returns undef.
250              
251             =cut
252             sub unify {
253 0     0 1   my ($this, $t1, $t2) = @_;
254            
255 0           $t1 = $this->find($t1);
256 0           $t2 = $this->find($t2);
257              
258             # The buck stops here if at least one is a VAR
259 0 0 0       if ($t1->type == Devel::TypeCheck::Type::VAR() &&
    0 0        
    0 0        
260             $t2->type == Devel::TypeCheck::Type::VAR()) {
261              
262             # The unification of two variable types is trivially their
263             # union.
264 0           return $this->union($t1, $t2);
265              
266              
267             # The next two clauses handle the case where a type variable needs
268             # to be unified with a concrete type. In both cases, we need to
269             # make sure that the type variable does not appear in the concrete
270             # type.
271             } elsif ($t1->type == Devel::TypeCheck::Type::VAR() &&
272             $t2->type != Devel::TypeCheck::Type::VAR()) {
273              
274 0 0         if (!$t2->occurs($t1, $this)) {
275 0           $t1->{'parent'} = $t2;
276 0           return $t2;
277             } else {
278 0           die("Failed occurs check");
279             }
280              
281             } elsif ($t1->type != Devel::TypeCheck::Type::VAR() &&
282             $t2->type == Devel::TypeCheck::Type::VAR()) {
283              
284 0 0         if (!$t1->occurs($t2, $this)) {
285 0           $t2->{'parent'} = $t1;
286 0           return $t1;
287             } else {
288 0           die("Failed occurs check");
289             }
290              
291             # In this clause, both t1 and t2 are concrete types
292             } else {
293              
294             # Call the type-specific unify. This handles the case where
295             # incomplete types need to be unified.
296 0 0         if ($t1->unify($t2, $this)) {
297 0           return $t1;
298             } else {
299 0           return undef;
300             }
301             }
302             }
303              
304             =item B($elt)
305              
306             Find the representative element of the set that C<<$elt>> belongs to.
307             For fully qualified types that end in a terminal, this is themselves.
308              
309             =cut
310             sub find {
311 0     0 1   my ($this, $elt) = @_;
312              
313 0 0         confess ("null find") if (!defined($elt));
314              
315 0 0         if (defined($elt->getParent)) {
316 0           return $elt->setParent($this->find($elt->getParent));
317             } else {
318 0           return $elt;
319             }
320             }
321              
322             TRUE;
323              
324             =back
325              
326             =head1 AUTHOR
327              
328             Gary Jackson, C<< >>
329              
330             =head1 BUGS
331              
332             This version is specific to Perl 5.8.1. It may work with other
333             versions that have the same opcode list and structure, but this is
334             entirely untested. It definitely will not work if those parameters
335             change.
336              
337             Please report any bugs or feature requests to
338             C, or through the web interface at
339             L.
340             I will be notified, and then you'll automatically be notified of progress on
341             your bug as I make changes.
342              
343             =head1 COPYRIGHT & LICENSE
344              
345             Copyright 2005 Gary Jackson, all rights reserved.
346              
347             This program is free software; you can redistribute it and/or modify it
348             under the same terms as Perl itself.
349              
350             =cut