perl/types.pm

   1 package types;
   2 use strict;
   3 use warnings FATAL => qw(all);
   4 use Exporter 'import';
   5 our @EXPORT_OK = qw(_sequential_Q _equal_Q _clone
   6                     $nil $true $false _nil_Q _true_Q _false_Q
   7                     _number_Q _symbol _symbol_Q _string_Q _keyword _keyword_Q _list_Q _vector_Q _sub_Q _function_Q
   8                     _hash_map _hash_map_Q _atom_Q);
   9 use List::Util qw(pairs pairmap);
  10
  11 use Data::Dumper;
  12
  13 # General functions
  14
  15 sub _sequential_Q {
  16     return _list_Q($_[0]) || _vector_Q($_[0])
  17 }
  18
  19 sub _equal_Q {
  20     my ($a, $b) = @_;
  21     my ($ota, $otb) = (ref $a, ref $b);
  22     if (!(($ota eq $otb) || (_sequential_Q($a) && _sequential_Q($b)))) {
  23         return 0;
  24     }
  25     if ($a->isa('Mal::Symbol')) {
  26         return $$a eq $$b;
  27     } elsif ($a->isa('Mal::Sequence')) {
  28         if (! (scalar(@$a) == scalar(@$b))) {
  29             return 0;
  30         }
  31         for (my $i=0; $i<scalar(@$a); $i++) {
  32             if (! _equal_Q($a->[$i], $b->[$i])) {
  33                 return 0;
  34             }
  35         }
  36         return 1;
  37     } elsif ($a->isa('Mal::HashMap')) {
  38         if (! (scalar(keys %$a) == scalar(keys %$b))) {
  39             return 0;
  40         }
  41         foreach my $k (keys %$a) {
  42             if (!_equal_Q($a->{$k}, $b->{$k})) {
  43                 return 0;
  44             }
  45         }
  46         return 1;
  47     } else {
  48         return $$a eq $$b;
  49     }
  50     return 0;
  51 }
  52
  53 sub _clone {
  54     no overloading '%{}';
  55     my ($obj) = @_;
  56     if ($obj->isa('Mal::CoreFunction')) {
  57         return Mal::FunctionRef->new( $obj );
  58     } else {
  59         return bless {%{$obj}}, ref $obj;
  60     }
  61 }
  62
  63 # Errors/Exceptions
  64
  65 {
  66     package Mal::BlankException;
  67     sub new { my $class = shift; bless Mal::String->new("Blank Line") => $class }
  68 }
  69
  70 # Scalars
  71
  72 {
  73     package Mal::Nil;
  74     # Allow nil to be treated as an empty list or hash-map.
  75     use overload '@{}' => sub { [] }, '%{}' => sub { {} }, fallback => 1;
  76     sub new { my $class = shift; my $s = 'nil'; bless \$s => $class }
  77     sub rest { Mal::List->new([]) }
  78 }
  79 {
  80     package Mal::True;
  81     sub new { my $class = shift; my $s = 'true'; bless \$s => $class }
  82 }
  83 {
  84     package Mal::False;
  85     sub new { my $class = shift; my $s = 'false'; bless \$s => $class }
  86 }
  87
  88 our $nil =   Mal::Nil->new();
  89 our $true =  Mal::True->new();
  90 our $false = Mal::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 Mal::Integer;
  99     sub new  { my $class = shift; bless \do { my $x=$_[0] }, $class }
 100 }
 101 sub _number_Q { $_[0]->isa('Mal::Integer') }
 102
 103
 104 {
 105     package Mal::Symbol;
 106     sub new  { my $class = shift; bless \do { my $x=$_[0] }, $class }
 107 }
 108 sub _symbol_Q { $_[0]->isa('Mal::Symbol') }
 109
 110
 111 sub _string_Q { $_[0]->isa('Mal::String') && ${$_[0]} !~ /^\x{029e}/; }
 112
 113
 114 sub _keyword { return Mal::String->new(("\x{029e}".$_[0])); }
 115 sub _keyword_Q { $_[0]->isa('Mal::String') && ${$_[0]} =~ /^\x{029e}/; }
 116
 117
 118 {
 119     package Mal::String;
 120     sub new  { my $class = shift; bless \$_[0] => $class }
 121 }
 122
 123
 124 # Sequences
 125
 126 {
 127     package Mal::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}}; Mal::List->new([@arr[1..$#arr]]); }
 133     sub slice { my @arr = @{$_[0]->{val}}; Mal::List->new([@arr[$_[1]..$_[2]]]); }
 134 }
 135
 136 # Lists
 137
 138 {
 139     package Mal::List;
 140     use parent -norequire, 'Mal::Sequence';
 141 }
 142
 143 sub _list_Q { $_[0]->isa('Mal::List') }
 144
 145
 146 # Vectors
 147
 148 {
 149     package Mal::Vector;
 150     use parent -norequire, 'Mal::Sequence';
 151 }
 152
 153 sub _vector_Q { $_[0]->isa('Mal::Vector') }
 154
 155
 156 # Hash Maps
 157
 158 {
 159     package Mal::HashMap;
 160     use overload '%{}' => sub { no overloading '%{}'; $_[0]->{val} },
 161                  fallback => 1;
 162     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 163     sub meta { no overloading '%{}'; $_[0]->{meta} }
 164 }
 165
 166 sub _hash_map { Mal::HashMap->new( { pairmap { $$a => $b } @_ } ) }
 167
 168 sub _hash_map_Q { $_[0]->isa('Mal::HashMap') }
 169
 170
 171 # Functions
 172
 173 {
 174     package Mal::Function;
 175     use overload '&{}' => sub { my $f = shift; sub { $f->apply(\@_) } },
 176                  fallback => 1;
 177     sub new  {
 178         my $class = shift;
 179         my ($eval, $ast, $env, $params) = @_;
 180         bless {'meta'=>$nil,
 181                'eval'=>$eval,
 182                'ast'=>$ast,
 183                'env'=>$env,
 184                'params'=>$params,
 185                'ismacro'=>0}, $class
 186     }
 187     sub meta { $_[0]->{meta} }
 188     sub gen_env {
 189         my $self = $_[0];
 190         return Mal::Env->new($self->{env}, $self->{params}, $_[1]);
 191     }
 192     sub apply {
 193         my $self = $_[0];
 194         return &{ $self->{eval} }($self->{ast}, gen_env($self, $_[1]));
 195     }
 196 }
 197
 198 sub _sub_Q { $_[0]->isa('Mal::CoreFunction') ||  $_[0]->isa('Mal::FunctionRef') }
 199 sub _function_Q { $_[0]->isa('Mal::Function') }
 200
 201
 202 # FunctionRef
 203
 204 {
 205     package Mal::FunctionRef;
 206     use overload '&{}' => sub { $_[0]->{code} }, fallback => 1;
 207     sub new {
 208         my ($class, $code) = @_;
 209         bless {'meta'=>$nil,
 210                'code'=>$code}, $class
 211     }
 212     sub meta { $_[0]->{meta} }
 213 }
 214
 215 # Core Functions
 216
 217 {
 218     package Mal::CoreFunction;
 219     sub meta { $nil }
 220 }
 221
 222
 223 # Atoms
 224
 225 {
 226     package Mal::Atom;
 227     use overload '${}' => sub { \($_[0]->{val}) }, fallback => 1;
 228     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 229     sub meta { $_[0]->{meta} }
 230 }
 231
 232 sub _atom_Q { $_[0]->isa('Mal::Atom') }
 233
 234 1;