File Coverage

blib/lib/Devel/TypeCheck/Type/Omicron.pm
Criterion Covered Total %
statement 15 173 8.6
branch 0 80 0.0
condition 0 9 0.0
subroutine 5 24 20.8
pod 13 19 68.4
total 33 305 10.8


line stmt bran cond sub pod time code
1             package Devel::TypeCheck::Type::Omicron;
2              
3             =head1 NAME
4              
5             Devel::TypeCheck::Type::Omicron - Type representing arrays.
6              
7             =head1 SYNOPSIS
8              
9             use Devel::TypeCheck::Type::Omicron;
10              
11             =head1 DESCRIPTION
12              
13             This class represents the Omicron (capital 'O') terminal in the type
14             language. As such, it maintains type information for arrays. This
15             class is a little bit different than the others, because it can
16             represent two essentially different types: lists of homogeneous typed
17             values, or tuples of heterogeneous types. This has an adaptation to
18             the unify() algorithm where a tuple can be unified with a list through
19             promotion to a list if all elements of the tuple can be unified with
20             the list element type. Lists cannot be demoted to tuples.
21              
22             Inherits from Devel::TypeCheck::Type and Devel::TypeCheck::TSub.
23              
24             =cut
25              
26 1     1   3372 use strict;
  1         2  
  1         44  
27 1     1   8 use Carp;
  1         2  
  1         80  
28              
29 1     1   7 use Devel::TypeCheck::Type;
  1         3  
  1         38  
30 1     1   7 use Devel::TypeCheck::Util;
  1         2  
  1         215  
31              
32             our @ISA = qw(Devel::TypeCheck::Type Devel::TypeCheck::Type::TSub);
33              
34             # **** CLASS ****
35              
36             our @SUBTYPES;
37             our @subtypes;
38              
39             BEGIN {
40 1     1   11 @SUBTYPES = (Devel::TypeCheck::Type::K());
41              
42 1         4 for my $i (@SUBTYPES) {
43 1         2235 $subtypes[$i] = 1;
44             }
45             }
46              
47             sub hasSubtype {
48 0     0 1   my ($this, $index) = @_;
49 0           return ($subtypes[$index]);
50             }
51              
52             # **** INSTANCE ****
53              
54             sub new {
55 0     0 1   my ($name, $type) = @_;
56              
57 0           my $this = {};
58              
59 0           $this->{'ref'} = newRef($type);
60              
61 0           return bless($this, $name);
62             }
63              
64             sub newRef {
65 0     0 0   my ($type) = @_;
66              
67 0           my $ref = {};
68              
69 0 0         if (defined($type)) {
70 0           $ref->{'ary'} = undef;
71 0           $ref->{'homogeneous'} = TRUE;
72 0           $ref->{'subtype'} = $type;
73             } else {
74 0           $ref->{'ary'} = [];
75 0           $ref->{'homogeneous'} = FALSE;
76 0           $ref->{'subtype'} = undef;
77             }
78              
79 0           return $ref;
80             }
81              
82             sub derefIndex {
83 0     0 1   my ($this, $index, $env) = @_;
84              
85 0 0         if (!defined($env)) {
86 0           confess("null environment");
87             }
88              
89 0 0         if ($this->homogeneous) {
90 0           return $this->derefHomogeneous;
91             } else {
92 0 0         confess("index is negative") if ($index < 0);
93              
94 0 0         if (!exists($this->ary->[$index])) {
95 0           $this->ary->[$index] = $env->freshKappa();
96             }
97            
98 0           return $this->ary->[$index];
99             }
100             }
101              
102             sub ary {
103 0     0 1   my ($this) = @_;
104 0           return $this->{'ref'}->{'ary'};
105             }
106              
107             sub subtype {
108 0     0 1   return undef;
109             }
110              
111             sub derefHomogeneous {
112 0     0 1   my ($this) = @_;
113 0 0         if ($this->homogeneous) {
114 0           return $this->{'ref'}->{'subtype'};
115             } else {
116 0           confess("type is not homogeneous");
117             }
118             }
119              
120             sub homogeneous {
121 0     0 1   my ($this) = @_;
122 0           return $this->{'ref'}->{'homogeneous'};
123             }
124              
125             sub str {
126 0     0 1   my ($this, $env) = @_;
127              
128 0 0         if ($this->homogeneous) {
129 0           return "(" . $this->derefHomogeneous->str($env) . ", ...)";
130             } else {
131 0           my $str = "(";
132              
133 0           my @str = ();
134 0           for (my $i = 0; $i <= $#{$this->ary}; $i++) {
  0            
135 0           push(@str, $this->derefIndex($i, $env)->str($env));
136             }
137            
138 0           $str .= join(",", @str);
139              
140 0           return $str . ")";
141             }
142             }
143              
144             sub pretty {
145 0     0 1   my ($this, $env) = @_;
146              
147 0 0         if ($this->homogeneous) {
148 0           return "LIST of (" . $this->derefHomogeneous->pretty($env) . ", ...)";
149             } else {
150 0           my $str = "TUPLE of (";
151              
152 0           my @str = ();
153 0           for (my $i = 0; $i <= $#{$this->ary}; $i++) {
  0            
154 0           push(@str, $this->derefIndex($i, $env)->pretty($env));
155             }
156            
157 0           $str .= join(",", @str);
158              
159 0           return $str . ")";
160             }
161             }
162              
163             sub copyFrom {
164 0     0 0   my ($this, $that) = @_;
165              
166 0           $this->{'ref'} = $that->{'ref'};
167             }
168              
169             sub bindUp {
170 0     0 0   my ($this, $that, $env) = @_;
171              
172 0 0         if (!defined($env)) {
173 0           confess("null environment");
174             }
175              
176 0 0         if (! $this->homogeneous) {
177 0           confess("Can not bind up against non-homogeneous array");
178             }
179              
180 0 0         if ($that->homogeneous) {
181 0           confess("Can not bind up homogeneous array to homogeneous array, unify instead");
182             }
183              
184 0           for (my $i = 0; $i <= $#{$that->ary}; $i++) {
  0            
185 0 0         if (!defined($env->unify($that->derefIndex($i, $env), $this->derefHomogeneous))) {
186 0           return undef;
187             }
188             }
189              
190 0           $that->copyFrom($this);
191              
192 0           return $this;
193             }
194              
195             sub tupleUnify {
196 0     0 0   my ($this, $that, $env) = @_;
197            
198 0 0         if (!defined($env)) {
199 0           confess("null environment");
200             }
201              
202 0 0 0       if ($this->homogeneous || $that->homogeneous) {
203 0           confess("Both inputs must not be homogeneous for tupleUnify");
204             }
205              
206 0           my $max = $this;
207 0           my $min = $that;
208              
209 0 0         if ($#{$that->ary} > $#{$this->ary}) {
  0            
  0            
210 0           $max = $that;
211 0           $min = $this;
212             }
213            
214 0           for (my $i = 0; $i <= ($#{$max->ary}); $i++) {
  0            
215 0 0         if (!defined($env->unify($max->derefIndex($i, $env), $min->derefIndex($i, $env)))) {
216 0           return undef;
217             }
218             }
219              
220 0           $that->copyFrom($this);
221            
222 0           return $this;
223             }
224            
225             sub unify {
226 0     0 0   my ($this, $that, $env) = @_;
227              
228 0           $this = $env->find($this);
229 0           $that = $env->find($that);
230              
231 0 0         if ($this->type == $that->type) {
232 0 0         if ($this->homogeneous) {
233 0 0         if ($that->homogeneous) {
234 0 0         if ($env->unify($this->derefHomogeneous, $that->derefHomogeneous)) {
235 0           return $this;
236             } else {
237 0           return undef;
238             }
239             } else {
240 0           return $this->bindUp($that, $env);
241             }
242             } else {
243 0 0         if ($that->homogeneous) {
244 0           return $that->bindUp($this, $env);
245             } else {
246 0           return $this->tupleUnify($that, $env);
247             }
248             }
249             } else {
250 0           return undef;
251             }
252             }
253              
254             sub type {
255 0     0 1   return Devel::TypeCheck::Type::O();
256             }
257              
258             # Do the occurs check against $that with the given environment $env.
259             sub occurs {
260 0     0 0   my ($this, $that, $env) = @_;
261            
262 0 0         if ($that->type != Devel::TypeCheck::Type::VAR()) {
263 0           die("Invalid type ", $that->str, " for occurs check");
264             }
265              
266 0 0         if ($this->homogeneous) {
267 0           return $this->derefHomogeneous->occurs($that, $env);
268             } else {
269 0           for (my $i = 0; $i <= $#{$this->ary}; $i++) {
  0            
270 0           my $occurs = $this->derefIndex($i, $env)->occurs($that, $env);
271 0 0         return $occurs if ($occurs);
272             }
273              
274 0           return FALSE();
275             }
276             }
277              
278             sub referize {
279 0     0 1   my ($this, $env) = @_;
280              
281 0 0         if ($this->homogeneous) {
282 0           return $env->genOmicron($env->genRho($this->derefHomogeneous()));
283             } else {
284 0           my @ary;
285 0           for (my $i = 0; $i <= $#{$this->ary}; $i++) {
  0            
286 0           push(@ary, $env->genRho($this->derefIndex($i, $env)));
287             }
288              
289 0           return $env->genOmicronTuple(@ary);
290             }
291             }
292              
293             # Append $that to $this: ($this, $that). Unify and promote to list where neccessary.
294             sub append {
295 0     0 1   my ($this, $that, $env, $root) = @_;
296              
297 0           $that = $env->find($that);
298              
299 0 0         if ($that->isa("Devel::TypeCheck::Type::Var")) {
300 0           $that = $env->unify($that, $env->genOmicron());
301             }
302              
303 0 0         if ($that->is(Devel::TypeCheck::Type::VAR())) {
304 0           $that = $env->unify($that, $env->freshKappa());
305 0 0         return undef if (!defined($that));
306             }
307              
308 0           my $ret;
309 0 0         if ($this->homogeneous) {
310 0 0 0       if ($that->is(Devel::TypeCheck::Type::O())) {
    0          
    0          
311 0           $ret = $env->unify($that, $root);
312             } elsif ($that->is(Devel::TypeCheck::Type::X())) {
313 0           my $list = $that->listCoerce($env);
314 0 0         if ($list) {
315 0           $ret = $env->unify($list, $root);
316             } else {
317 0           $ret = undef;
318             }
319             } elsif ($that->is(Devel::TypeCheck::Type::K()) ||
320             $that->is(Devel::TypeCheck::Type::Z())) {
321 0           $ret = $env->unify($env->genOmicron($that), $root);
322             } else {
323 0           confess("Unknown type in append");
324             }
325             } else {
326 0 0 0       if ($that->is(Devel::TypeCheck::Type::O())) {
    0          
    0          
327 0 0         if ($that->homogeneous) {
328 0           $ret = $env->unify($root, $that);
329             } else {
330 0           my $list = $env->genOmicron($env->freshKappa);
331 0           my $tl = $env->unify($that, $list);
332 0 0         if ($tl) {
333 0           $ret = $env->unify($root, $tl);
334             } else {
335 0           $ret = undef;
336             }
337             }
338             } elsif ($that->is(Devel::TypeCheck::Type::X())) {
339 0           my $list = $that->listCoerce($env);
340 0 0         if ($list) {
341 0           $ret = $env->unify($list, $root);
342             } else {
343 0           $ret = undef;
344             }
345             } elsif ($that->is(Devel::TypeCheck::Type::K()) ||
346             $that->is(Devel::TypeCheck::Type::Z())) {
347 0           $ret = $env->genOmicronTuple((@{$this->ary}, $that));
  0            
348             } else {
349 0           confess("Unknown type in append");
350             }
351             }
352              
353 0           return $ret;
354             }
355              
356             sub arity {
357 0     0 1   my ($this) = @_;
358              
359 0 0         if ($this->homogeneous) {
360 0           confess("Omicron is homogeneous");
361             } else {
362 0           return ($#{$this->ary} + 1);
  0            
363             }
364             }
365              
366             TRUE;
367              
368             =head1 AUTHOR
369              
370             Gary Jackson, C<< >>
371              
372             =head1 BUGS
373              
374             This version is specific to Perl 5.8.1. It may work with other
375             versions that have the same opcode list and structure, but this is
376             entirely untested. It definitely will not work if those parameters
377             change.
378              
379             Please report any bugs or feature requests to
380             C, or through the web interface at
381             L.
382             I will be notified, and then you'll automatically be notified of progress on
383             your bug as I make changes.
384              
385             =head1 COPYRIGHT & LICENSE
386              
387             Copyright 2005 Gary Jackson, all rights reserved.
388              
389             This program is free software; you can redistribute it and/or modify it
390             under the same terms as Perl itself.
391              
392             =cut