perl/types.pm

   1 package types;
   2 use strict;
   3 use warnings FATAL => qw(all);
   4 no if $] >= 5.018, warnings => "experimental::smartmatch";
   5 use feature qw(switch);
   6 use Exporter 'import';
   7 our @EXPORT_OK = qw(_sequential_Q _equal_Q _clone
   8                     $nil $true $false _nil_Q _true_Q _false_Q
   9                     _number_Q _symbol _symbol_Q _string_Q _keyword _keyword_Q _list_Q _vector_Q _sub_Q _function_Q
  10                     _hash_map _hash_map_Q _assoc_BANG _dissoc_BANG _atom_Q);
  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);
  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/) {
  31             if (! (scalar(@{$a->{val}}) == scalar(@{$b->{val}}))) {
  32                 return 0;
  33             }
  34             for (my $i=0; $i<scalar(@{$a->{val}}); $i++) {
  35                 if (! _equal_Q($a->nth($i), $b->nth($i))) {
  36                     return 0;
  37                 }
  38             }
  39             return 1;
  40         }
  41         when (/^HashMap/) {
  42             if (! (scalar(keys %{ $a->{val} }) == scalar(keys %{ $b->{val} }))) {
  43                 return 0;
  44             }
  45             foreach my $k (keys %{ $a->{val} }) {
  46                 if (!_equal_Q($a->{val}->{$k}, $b->{val}->{$k})) {
  47                     return 0;
  48                 }
  49             }
  50             return 1;
  51         }
  52         default {
  53             return $$a eq $$b;
  54         }
  55     }
  56     return 0;
  57 }
  58
  59 sub _clone {
  60     my ($obj) = @_;
  61     given (ref $obj) {
  62         when (/^CODE/) {
  63             return FunctionRef->new( $obj );
  64         }
  65         default {
  66             return bless {%{$obj}}, ref $obj;
  67         }
  68     }
  69 }
  70
  71 # Errors/Exceptions
  72
  73 {
  74     package BlankException;
  75     sub new { my $class = shift; bless String->new("Blank Line") => $class }
  76 }
  77
  78 # Scalars
  79
  80 {
  81     package Nil;
  82     sub new { my $class = shift; my $s = 'nil'; bless \$s => $class }
  83 }
  84 {
  85     package True;
  86     sub new { my $class = shift; my $s = 'true'; bless \$s => $class }
  87 }
  88 {
  89     package False;
  90     sub new { my $class = shift; my $s = 'false'; bless \$s => $class }
  91 }
  92
  93 our $nil =   Nil->new();
  94 our $true =  True->new();
  95 our $false = False->new();
  96
  97 sub _nil_Q   { return $_[0] eq $nil }
  98 sub _true_Q  { return $_[0] eq $true }
  99 sub _false_Q { return $_[0] eq $false }
 100
 101
 102 {
 103     package Integer;
 104     sub new  { my $class = shift; bless \do { my $x=$_[0] }, $class }
 105 }
 106 sub _number_Q { (ref $_[0]) =~ /^Integer/ }
 107
 108
 109 {
 110     package Symbol;
 111     sub new  { my $class = shift; bless \do { my $x=$_[0] }, $class }
 112 }
 113 sub _symbol_Q { (ref $_[0]) =~ /^Symbol/ }
 114
 115
 116 sub _string_Q { ((ref $_[0]) =~ /^String/) && ${$_[0]} !~ /^\x{029e}/; }
 117
 118
 119 sub _keyword { return String->new(("\x{029e}".$_[0])); }
 120 sub _keyword_Q { ((ref $_[0]) =~ /^String/) && ${$_[0]} =~ /^\x{029e}/; }
 121
 122
 123 {
 124     package String;
 125     sub new  { my $class = shift; bless \$_[0] => $class }
 126 }
 127
 128
 129 # Sequences
 130
 131 {
 132     package Sequence;
 133     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 134     sub nth { $_[0]->{val}->[$_[1]]; }
 135     #sub _val { $_[0]->{val}->[$_[1]]->{val}; } # return value of nth item
 136     sub rest { my @arr = @{$_[0]->{val}}; List->new([@arr[1..$#arr]]); }
 137     sub slice { my @arr = @{$_[0]->{val}}; List->new([@arr[$_[1]..$_[2]]]); }
 138 }
 139
 140 # Lists
 141
 142 {
 143     package List;
 144     use parent -norequire, 'Sequence';
 145 }
 146
 147 sub _list_Q { (ref $_[0]) =~ /^List/ }
 148
 149
 150 # Vectors
 151
 152 {
 153     package Vector;
 154     use parent -norequire, 'Sequence';
 155 }
 156
 157 sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
 158
 159
 160 # Hash Maps
 161
 162 {
 163     package HashMap;
 164     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 165     sub get { $_[0]->{val}->{$_[1]}; }
 166 }
 167
 168 sub _hash_map {
 169     my $hsh = {};
 170     return _assoc_BANG($hsh, @_);
 171 }
 172
 173 sub _assoc_BANG {
 174     my $hsh = shift;
 175     my @lst = @_;
 176     for(my $i=0; $i<scalar(@lst); $i+=2) {
 177         my $str = $lst[$i];
 178         $hsh->{$$str} = $lst[$i+1];
 179     }
 180     return HashMap->new($hsh);
 181 }
 182
 183 sub _dissoc_BANG {
 184     my $hsh = shift;
 185     my @lst = @_;
 186     for(my $i=0; $i<scalar(@lst); $i++) {
 187         my $str = $lst[$i];
 188         delete $hsh->{$$str};
 189     }
 190     return HashMap->new($hsh);
 191 }
 192
 193 sub _hash_map_Q { (ref $_[0]) =~ /^HashMap/ }
 194
 195
 196 # Functions
 197
 198 {
 199     package Function;
 200     sub new  {
 201         my $class = shift;
 202         my ($eval, $ast, $env, $params) = @_;
 203         bless {'meta'=>$nil,
 204                'eval'=>$eval,
 205                'ast'=>$ast,
 206                'env'=>$env,
 207                'params'=>$params,
 208                'ismacro'=>0}, $class
 209     }
 210     sub gen_env {
 211         my $self = $_[0];
 212         return Env->new($self->{env}, $self->{params}, $_[1]);
 213     }
 214     sub apply {
 215         my $self = $_[0];
 216         return &{ $self->{eval} }($self->{ast}, gen_env($self, $_[1]));
 217     }
 218 }
 219
 220 sub _sub_Q { (ref $_[0]) =~ /^CODE/ }
 221 sub _function_Q { (ref $_[0]) =~ /^Function/ }
 222
 223
 224 # FunctionRef
 225
 226 {
 227     package FunctionRef;
 228     sub new {
 229         my ($class, $code) = @_;
 230         bless {'meta'=>$nil,
 231                'code'=>$code}, $class
 232     }
 233     sub apply {
 234         my $self = $_[0];
 235         return &{ $self->{code} }($_[1]);
 236     }
 237 }
 238
 239
 240 # Atoms
 241
 242 {
 243     package Atom;
 244     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 245 }
 246
 247 sub _atom_Q { (ref $_[0]) =~ /^Atom/ }
 248
 249 1;