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('Symbol')) {
  26         return $$a eq $$b;
  27     } elsif ($a->isa('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('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('CoreFunction')) {
  57         return FunctionRef->new( $obj );
  58     } else {
  59         return bless {%{$obj}}, ref $obj;
  60     }
  61 }
  62
  63 # Errors/Exceptions
  64
  65 {
  66     package BlankException;
  67     sub new { my $class = shift; bless String->new("Blank Line") => $class }
  68 }
  69
  70 # Scalars
  71
  72 {
  73     package 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 { List->new([]) }
  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     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     sub get { no overloading '%{}'; $_[0]->{val}->{$_[1]}; }
 165 }
 166
 167 sub _hash_map { HashMap->new( { pairmap { $$a => $b } @_ } ) }
 168
 169 sub _hash_map_Q { $_[0]->isa('HashMap') }
 170
 171
 172 # Functions
 173
 174 {
 175     package Function;
 176     use overload '&{}' => sub { my $f = shift; sub { $f->apply(\@_) } },
 177                  fallback => 1;
 178     sub new  {
 179         my $class = shift;
 180         my ($eval, $ast, $env, $params) = @_;
 181         bless {'meta'=>$nil,
 182                'eval'=>$eval,
 183                'ast'=>$ast,
 184                'env'=>$env,
 185                'params'=>$params,
 186                'ismacro'=>0}, $class
 187     }
 188     sub meta { $_[0]->{meta} }
 189     sub gen_env {
 190         my $self = $_[0];
 191         return Env->new($self->{env}, $self->{params}, $_[1]);
 192     }
 193     sub apply {
 194         my $self = $_[0];
 195         return &{ $self->{eval} }($self->{ast}, gen_env($self, $_[1]));
 196     }
 197 }
 198
 199 sub _sub_Q { $_[0]->isa('CoreFunction') ||  $_[0]->isa('FunctionRef') }
 200 sub _function_Q { $_[0]->isa('Function') }
 201
 202
 203 # FunctionRef
 204
 205 {
 206     package FunctionRef;
 207     use overload '&{}' => sub { $_[0]->{code} }, fallback => 1;
 208     sub new {
 209         my ($class, $code) = @_;
 210         bless {'meta'=>$nil,
 211                'code'=>$code}, $class
 212     }
 213     sub meta { $_[0]->{meta} }
 214 }
 215
 216 # Core Functions
 217
 218 {
 219     package CoreFunction;
 220     sub meta { $nil }
 221 }
 222
 223
 224 # Atoms
 225
 226 {
 227     package Atom;
 228     use overload '${}' => sub { \($_[0]->{val}) }, fallback => 1;
 229     sub new  { my $class = shift; bless {'meta'=>$nil, 'val'=>$_[0]}, $class }
 230     sub meta { $_[0]->{meta} }
 231 }
 232
 233 sub _atom_Q { $_[0]->isa('Atom') }
 234
 235 1;