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