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                     _symbol _symbol_Q _keyword _keyword_Q _list_Q _vector_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             die "TODO: Hash map comparison\n";
  43         }
  44         default {
  45             return $$a eq $$b;
  46         }
  47     }
  48     return 0;
  49 }
  50
  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 HashMap->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
  79 # Scalars
  80
  81 {
  82     package Nil;
  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
  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
 103 {
 104     package Integer;
 105     sub new  { my $class = shift; bless \do { my $x=$_[0] }, $class }
 106 }
 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 _keyword { return String->new(("\x{029e}".$_[0])); }
 117 sub _keyword_Q { ((ref $_[0]) =~ /^String/) && ${$_[0]} =~ /^\x{029e}/; }
 118
 119
 120 {
 121     package String;
 122     sub new  { my $class = shift; bless \$_[0] => $class }
 123 }
 124
 125
 126 # Lists
 127
 128 {
 129     package List;
 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]]]); }
 135 }
 136
 137 sub _list_Q { (ref $_[0]) =~ /^List/ }
 138
 139
 140 # Vectors
 141
 142 {
 143     package Vector;
 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]]]); }
 149 }
 150
 151 sub _vector_Q { (ref $_[0]) =~ /^Vector/ }
 152
 153
 154 # Hash Maps
 155
 156 {
 157     package HashMap;
 158     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 159     sub get { $_[0]->{val}->{$_[1]}; }
 160 }
 161
 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
 189
 190 # Functions
 191
 192 {
 193     package Function;
 194     sub new  {
 195         my $class = shift;
 196         my ($eval, $ast, $env, $params) = @_;
 197         bless {'meta'=>$nil,
 198                'eval'=>$eval,
 199                'ast'=>$ast,
 200                'env'=>$env,
 201                'params'=>$params,
 202                'ismacro'=>0}, $class
 203     }
 204     sub new_from_hash { my $class = shift; bless $_[0], $class }
 205     sub gen_env {
 206         my $self = $_[0];
 207         return Env->new($self->{env}, $self->{params}, $_[1]);
 208     }
 209     sub apply {
 210         my $self = $_[0];
 211         return &{ $self->{eval} }($self->{ast}, gen_env($self, $_[1]));
 212     }
 213 }
 214
 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
 225 1;