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 # Lists
 130
 131 {
 132     package List;
 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 sub _list_Q { (ref $_[0]) =~ /^List/ }
 141
 142
 143 # Vectors
 144
 145 {
 146     package Vector;
 147     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 148     sub nth { $_[0]->{val}->[$_[1]]; }
 149     #sub _val { $_[0]->{val}->[$_[1]]->{val}; } # return value of nth item
 150     sub rest { my @arr = @{$_[0]->{val}}; List->new([@arr[1..$#arr]]); }
 151     sub slice { my @arr = @{$_[0]->{val}}; List->new([@arr[$_[1]..$_[2]]]); }
 152 }
 153
 154 sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
 155
 156
 157 # Hash Maps
 158
 159 {
 160     package HashMap;
 161     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 162     sub get { $_[0]->{val}->{$_[1]}; }
 163 }
 164
 165 sub _hash_map {
 166     my $hsh = {};
 167     return _assoc_BANG($hsh, @_);
 168 }
 169
 170 sub _assoc_BANG {
 171     my $hsh = shift;
 172     my @lst = @_;
 173     for(my $i=0; $i<scalar(@lst); $i+=2) {
 174         my $str = $lst[$i];
 175         $hsh->{$$str} = $lst[$i+1];
 176     }
 177     return HashMap->new($hsh);
 178 }
 179
 180 sub _dissoc_BANG {
 181     my $hsh = shift;
 182     my @lst = @_;
 183     for(my $i=0; $i<scalar(@lst); $i++) {
 184         my $str = $lst[$i];
 185         delete $hsh->{$$str};
 186     }
 187     return HashMap->new($hsh);
 188 }
 189
 190 sub _hash_map_Q { (ref $_[0]) =~ /^HashMap/ }
 191
 192
 193 # Functions
 194
 195 {
 196     package Function;
 197     sub new  {
 198         my $class = shift;
 199         my ($eval, $ast, $env, $params) = @_;
 200         bless {'meta'=>$nil,
 201                'eval'=>$eval,
 202                'ast'=>$ast,
 203                'env'=>$env,
 204                'params'=>$params,
 205                'ismacro'=>0}, $class
 206     }
 207     sub gen_env {
 208         my $self = $_[0];
 209         return Env->new($self->{env}, $self->{params}, $_[1]);
 210     }
 211     sub apply {
 212         my $self = $_[0];
 213         return &{ $self->{eval} }($self->{ast}, gen_env($self, $_[1]));
 214     }
 215 }
 216
 217 sub _sub_Q { (ref $_[0]) =~ /^CODE/ }
 218 sub _function_Q { (ref $_[0]) =~ /^Function/ }
 219
 220
 221 # FunctionRef
 222
 223 {
 224     package FunctionRef;
 225     sub new {
 226         my ($class, $code) = @_;
 227         bless {'meta'=>$nil,
 228                'code'=>$code}, $class
 229     }
 230     sub apply {
 231         my $self = $_[0];
 232         return &{ $self->{code} }($_[1]);
 233     }
 234 }
 235
 236
 237 # Atoms
 238
 239 {
 240     package Atom;
 241     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 242 }
 243
 244 sub _atom_Q { (ref $_[0]) =~ /^Atom/ }
 245
 246 1;