Commit | Line | Data |
---|---|---|
b5dedee0 JM |
1 | package types; |
2 | use strict; | |
60f2b363 | 3 | use warnings FATAL => qw(all); |
01c97316 | 4 | no if $] >= 5.018, warnings => "experimental::smartmatch"; |
a5a66058 | 5 | use feature qw(switch); |
b5dedee0 | 6 | use Exporter 'import'; |
89bd4de1 | 7 | our @EXPORT_OK = qw(_sequential_Q _equal_Q _clone |
b8ee29b2 JM |
8 | $nil $true $false _nil_Q _true_Q _false_Q |
9 | _symbol _symbol_Q _keyword _keyword_Q _list_Q _vector_Q | |
10 | _hash_map _hash_map_Q _assoc_BANG _dissoc_BANG _atom_Q); | |
a5a66058 JM |
11 | |
12 | use Data::Dumper; | |
13 | ||
14 | # General functions | |
15 | ||
16 | sub _sequential_Q { | |
17 | return _list_Q($_[0]) || _vector_Q($_[0]) | |
18 | } | |
19 | ||
20 | sub _equal_Q { | |
21 | my ($a, $b) = @_; | |
22 | my ($ota, $otb) = (ref $a, ref $b); | |
a5a66058 JM |
23 | if (!(($ota eq $otb) || (_sequential_Q($a) && _sequential_Q($b)))) { |
24 | return 0; | |
25 | } | |
26 | given (ref $a) { | |
27 | when (/^Symbol/) { | |
28 | return $$a eq $$b; | |
29 | } | |
30 | when (/^List/ || /^Vector/) { | |
89bd4de1 | 31 | if (! scalar(@{$a->{val}}) == scalar(@{$b->{val}})) { |
a5a66058 JM |
32 | return 0; |
33 | } | |
89bd4de1 JM |
34 | for (my $i=0; $i<scalar(@{$a->{val}}); $i++) { |
35 | if (! _equal_Q($a->nth($i), $b->nth($i))) { | |
a5a66058 JM |
36 | return 0; |
37 | } | |
38 | } | |
39 | return 1; | |
40 | } | |
89bd4de1 JM |
41 | when (/^HashMap/) { |
42 | die "TODO: Hash map comparison\n"; | |
43 | } | |
a5a66058 JM |
44 | default { |
45 | return $$a eq $$b; | |
46 | } | |
47 | } | |
48 | return 0; | |
49 | } | |
50 | ||
89bd4de1 JM |
51 | sub _clone { |
52 | my ($obj) = @_; | |
53 | given (ref $obj) { | |
54 | when (/^List/) { | |
55 | return List->new( [ @{$obj->{val}} ] ); | |
56 | } | |
57 | when (/^Vector/) { | |
58 | return Vector->new( [ @{$obj->{val}} ] ); | |
59 | } | |
60 | when (/^HashMap/) { | |
61 | return Vector->new( { %{$obj->{val}} } ); | |
62 | } | |
63 | when (/^Function/) { | |
64 | return Function->new_from_hash( { %{$obj} } ); | |
65 | } | |
66 | default { | |
67 | die "Clone of non-collection\n"; | |
68 | } | |
69 | } | |
70 | } | |
71 | ||
72 | # Errors/Exceptions | |
73 | ||
74 | { | |
75 | package BlankException; | |
76 | sub new { my $class = shift; bless String->new("Blank Line") => $class } | |
77 | } | |
78 | ||
a5a66058 | 79 | # Scalars |
b5dedee0 JM |
80 | |
81 | { | |
82 | package Nil; | |
b5dedee0 JM |
83 | sub new { my $class = shift; my $s = 'nil'; bless \$s => $class } |
84 | } | |
85 | { | |
86 | package True; | |
87 | sub new { my $class = shift; my $s = 'true'; bless \$s => $class } | |
88 | } | |
89 | { | |
90 | package False; | |
91 | sub new { my $class = shift; my $s = 'false'; bless \$s => $class } | |
92 | } | |
93 | ||
94 | our $nil = Nil->new(); | |
95 | our $true = True->new(); | |
96 | our $false = False->new(); | |
97 | ||
16354bb4 JM |
98 | sub _nil_Q { return $_[0] eq $nil } |
99 | sub _true_Q { return $_[0] eq $true } | |
100 | sub _false_Q { return $_[0] eq $false } | |
101 | ||
102 | ||
b5dedee0 JM |
103 | { |
104 | package Integer; | |
105 | sub new { my $class = shift; bless \$_[0] => $class } | |
106 | } | |
107 | ||
a3b0621d | 108 | |
b5dedee0 JM |
109 | { |
110 | package Symbol; | |
111 | sub new { my $class = shift; bless \$_[0] => $class } | |
112 | } | |
b50cb97c | 113 | sub _symbol_Q { (ref $_[0]) =~ /^Symbol/ } |
a3b0621d JM |
114 | |
115 | ||
b8ee29b2 JM |
116 | sub _keyword { return String->new(("\x{029e}".$_[0])); } |
117 | sub _keyword_Q { ((ref $_[0]) =~ /^String/) && ${$_[0]} =~ /^\x{029e}/; } | |
118 | ||
119 | ||
b5dedee0 JM |
120 | { |
121 | package String; | |
122 | sub new { my $class = shift; bless \$_[0] => $class } | |
123 | } | |
124 | ||
a3b0621d | 125 | |
a5a66058 JM |
126 | # Lists |
127 | ||
b5dedee0 JM |
128 | { |
129 | package List; | |
89bd4de1 JM |
130 | sub new { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class } |
131 | sub nth { $_[0]->{val}->[$_[1]]; } | |
132 | #sub _val { $_[0]->{val}->[$_[1]]->{val}; } # return value of nth item | |
133 | sub rest { my @arr = @{$_[0]->{val}}; List->new([@arr[1..$#arr]]); } | |
134 | sub slice { my @arr = @{$_[0]->{val}}; List->new([@arr[$_[1]..$_[2]]]); } | |
b5dedee0 JM |
135 | } |
136 | ||
a5a66058 JM |
137 | sub _list_Q { (ref $_[0]) =~ /^List/ } |
138 | ||
a3b0621d | 139 | |
a5a66058 | 140 | # Vectors |
a3b0621d | 141 | |
b5dedee0 JM |
142 | { |
143 | package Vector; | |
89bd4de1 JM |
144 | sub new { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class } |
145 | sub nth { $_[0]->{val}->[$_[1]]; } | |
146 | #sub _val { $_[0]->{val}->[$_[1]]->{val}; } # return value of nth item | |
147 | sub rest { my @arr = @{$_[0]->{val}}; List->new([@arr[1..$#arr]]); } | |
148 | sub slice { my @arr = @{$_[0]->{val}}; List->new([@arr[$_[1]..$_[2]]]); } | |
b5dedee0 JM |
149 | } |
150 | ||
a5a66058 JM |
151 | sub _vector_Q { (ref $_[0]) =~ /^Vector/ } |
152 | ||
153 | ||
154 | # Hash Maps | |
a3b0621d | 155 | |
b5dedee0 JM |
156 | { |
157 | package HashMap; | |
89bd4de1 JM |
158 | sub new { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class } |
159 | sub get { $_[0]->{val}->{$_[1]}; } | |
b5dedee0 JM |
160 | } |
161 | ||
16354bb4 JM |
162 | sub _hash_map { |
163 | my $hsh = {}; | |
164 | return _assoc_BANG($hsh, @_); | |
165 | } | |
166 | ||
167 | sub _assoc_BANG { | |
168 | my $hsh = shift; | |
169 | my @lst = @_; | |
170 | for(my $i=0; $i<scalar(@lst); $i+=2) { | |
171 | my $str = $lst[$i]; | |
172 | $hsh->{$$str} = $lst[$i+1]; | |
173 | } | |
174 | return HashMap->new($hsh); | |
175 | } | |
176 | ||
177 | sub _dissoc_BANG { | |
178 | my $hsh = shift; | |
179 | my @lst = @_; | |
180 | for(my $i=0; $i<scalar(@lst); $i++) { | |
181 | my $str = $lst[$i]; | |
182 | delete $hsh->{$$str}; | |
183 | } | |
184 | return HashMap->new($hsh); | |
185 | } | |
186 | ||
187 | sub _hash_map_Q { (ref $_[0]) =~ /^HashMap/ } | |
188 | ||
60f2b363 JM |
189 | |
190 | # Functions | |
191 | ||
192 | { | |
193 | package Function; | |
194 | sub new { | |
195 | my $class = shift; | |
196 | my ($eval, $ast, $env, $params) = @_; | |
89bd4de1 JM |
197 | bless {'meta'=>$nil, |
198 | 'eval'=>$eval, | |
60f2b363 JM |
199 | 'ast'=>$ast, |
200 | 'env'=>$env, | |
b50cb97c JM |
201 | 'params'=>$params, |
202 | 'ismacro'=>0}, $class | |
60f2b363 | 203 | } |
89bd4de1 | 204 | sub new_from_hash { my $class = shift; bless $_[0], $class } |
60f2b363 | 205 | sub gen_env { |
b50cb97c JM |
206 | my $self = $_[0]; |
207 | return Env->new($self->{env}, $self->{params}, $_[1]); | |
60f2b363 JM |
208 | } |
209 | sub apply { | |
b50cb97c JM |
210 | my $self = $_[0]; |
211 | return &{ $self->{eval} }($self->{ast}, gen_env($self, $_[1])); | |
60f2b363 JM |
212 | } |
213 | } | |
214 | ||
89bd4de1 JM |
215 | |
216 | # Atoms | |
217 | ||
218 | { | |
219 | package Atom; | |
220 | sub new { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class } | |
221 | } | |
222 | ||
223 | sub _atom_Q { (ref $_[0]) =~ /^Atom/ } | |
224 | ||
b5dedee0 | 225 | 1; |