perl/types.pm

   1 package types;
   2 use strict;
   3 use warnings;
   4
   5 use Data::Dumper;
   6 use Exporter 'import';
   7 our @EXPORT_OK = qw(_equal_Q thaw_key
   8                     $nil $true $false);
   9
  10 # General functions
  11
  12 sub _equal_Q {
  13     my ($a, $b) = @_;
  14     unless ((ref $a eq ref $b) ||
  15             ($a->isa('Mal::Sequence') && $b->isa('Mal::Sequence'))) {
  16         return 0;
  17     }
  18     if ($a->isa('Mal::Sequence')) {
  19         unless (scalar(@$a) == scalar(@$b)) {
  20             return 0;
  21         }
  22         for (my $i=0; $i<scalar(@$a); $i++) {
  23             unless (_equal_Q($a->[$i], $b->[$i])) {
  24                 return 0;
  25             }
  26         }
  27         return 1;
  28     } elsif ($a->isa('Mal::HashMap')) {
  29         unless (scalar(keys %$a) == scalar(keys %$b)) {
  30             return 0;
  31         }
  32         foreach my $k (keys %$a) {
  33             unless (_equal_Q($a->{$k}, $b->{$k})) {
  34                 return 0;
  35             }
  36         }
  37         return 1;
  38     } else {
  39         return $$a eq $$b;
  40     }
  41     return 0;
  42 }
  43
  44
  45 # Errors/Exceptions
  46
  47 {
  48     package Mal::BlankException;
  49     sub new { my $class = shift; bless Mal::String->new("Blank Line") => $class }
  50 }
  51
  52 # Superclass for all kinds of mal value
  53
  54 {
  55     package Mal::Type;
  56 }
  57
  58 # Scalars
  59
  60 {
  61     package Mal::Scalar;
  62     use parent -norequire, 'Mal::Type';
  63     # Overload stringification so that its result is something
  64     # suitable for use as a hash-map key.  The important thing here is
  65     # that strings and keywords are distinct: support for other kinds
  66     # of scalar is a bonus.
  67     use overload '""' => sub { my $self = shift; ref($self) . " " . $$self },
  68         fallback => 1;
  69     sub new { my ($class, $value) = @_; bless \$value, $class }
  70 }
  71
  72 # This function converts hash-map keys back into full objects
  73
  74 sub thaw_key ($) {
  75     my ($class, $value) = split(/ /, $_[0], 2);
  76     return $class->new($value);
  77 }
  78
  79 {
  80     package Mal::Nil;
  81     use parent -norequire, 'Mal::Scalar';
  82     # Allow nil to be treated as an empty list or hash-map.
  83     use overload '@{}' => sub { [] }, '%{}' => sub { {} }, fallback => 1;
  84     sub rest { Mal::List->new([]) }
  85 }
  86 {
  87     package Mal::True;
  88     use parent -norequire, 'Mal::Scalar';
  89 }
  90 {
  91     package Mal::False;
  92     use parent -norequire, 'Mal::Scalar';
  93 }
  94
  95 our $nil =   Mal::Nil->new('nil');
  96 our $true =  Mal::True->new('true');
  97 our $false = Mal::False->new('false');
  98
  99
 100 {
 101     package Mal::Integer;
 102     use parent -norequire, 'Mal::Scalar';
 103 }
 104
 105
 106 {
 107     package Mal::Symbol;
 108     use parent -norequire, 'Mal::Scalar';
 109 }
 110
 111
 112 {
 113     package Mal::String;
 114     use parent -norequire, 'Mal::Scalar';
 115 }
 116
 117
 118 {
 119     package Mal::Keyword;
 120     use parent -norequire, 'Mal::Scalar';
 121 }
 122
 123
 124 # Sequences
 125
 126 {
 127     package Mal::Sequence;
 128     use parent -norequire, 'Mal::Type';
 129     sub new  { my $class = shift; bless $_[0], $class }
 130     sub rest { my $arr = $_[0]; Mal::List->new([@$arr[1..$#$arr]]); }
 131     sub clone { my $self = shift; ref($self)->new([@$self]) }
 132 }
 133
 134 # Lists
 135
 136 {
 137     package Mal::List;
 138     use parent -norequire, 'Mal::Sequence';
 139 }
 140
 141
 142 # Vectors
 143
 144 {
 145     package Mal::Vector;
 146     use parent -norequire, 'Mal::Sequence';
 147 }
 148
 149
 150 # Hash-maps
 151
 152 {
 153     package Mal::HashMap;
 154     use parent -norequire, 'Mal::Type';
 155     use List::Util qw(pairmap);
 156     use Scalar::Util qw(reftype);
 157     sub new  {
 158         my ($class, $src) = @_;
 159         if (reftype($src) eq 'ARRAY') {
 160             $src = {@$src};
 161         }
 162         return bless $src, $class;
 163     }
 164     sub clone { my $self = shift; ref($self)->new({%$self}) }
 165 }
 166
 167
 168 # Functions
 169
 170 {
 171     package Mal::Callable;
 172     use parent -norequire, 'Mal::Type';
 173     sub new  { my $class = shift; bless $_[0], $class }
 174     sub clone { my $self = shift; bless sub { goto &$self }, ref($self) }
 175 }
 176
 177 {
 178     package Mal::Function;
 179     use parent -norequire, 'Mal::Callable';
 180 }
 181
 182 {
 183     package Mal::Macro;
 184     use parent -norequire, 'Mal::Callable';
 185 }
 186
 187
 188 # Atoms
 189
 190 {
 191     package Mal::Atom;
 192     use parent -norequire, 'Mal::Type';
 193     sub new  { my ($class, $val) = @_; bless \$val, $class }
 194     sub clone { my $self = shift; ref($self)->new($$self) }
 195 }
 196
 197 1;