mirror of
https://github.com/kanaka/mal.git
synced 2024-10-27 06:40:14 +03:00
219 lines
3.6 KiB
Perl
219 lines
3.6 KiB
Perl
package Types;
|
|
use re '/msx';
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Exporter 'import';
|
|
|
|
our @EXPORT_OK = qw(equal_q thaw_key
|
|
nil true false);
|
|
|
|
## no critic (Modules::ProhibitMultiplePackages)
|
|
|
|
# General functions
|
|
|
|
sub equal_q {
|
|
my ( $a, $b ) = @_;
|
|
if ( $a->isa('Mal::Sequence') ) {
|
|
$b->isa('Mal::Sequence') or return 0;
|
|
scalar @{$a} == scalar @{$b} or return 0;
|
|
for ( 0 .. $#{$a} ) {
|
|
equal_q( $a->[$_], $b->[$_] ) or return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
ref $b eq ref $a or return 0;
|
|
if ( $a->isa('Mal::HashMap') ) {
|
|
scalar keys %{$a} == scalar keys %{$b} or return 0;
|
|
while ( my ( $k, $v ) = each %{$a} ) {
|
|
equal_q( $v, $b->{$k} ) or return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
return ${$a} eq ${$b};
|
|
}
|
|
|
|
# Superclass for all kinds of mal value
|
|
|
|
{
|
|
|
|
package Mal::Type;
|
|
}
|
|
|
|
# Scalars
|
|
|
|
{
|
|
|
|
package Mal::Scalar;
|
|
use parent -norequire, 'Mal::Type';
|
|
|
|
# Overload stringification so that its result is something
|
|
# suitable for use as a hash-map key. The important thing here is
|
|
# that strings and keywords are distinct: support for other kinds
|
|
# of scalar is a bonus.
|
|
use overload
|
|
'""' => sub { my $self = shift; ref($self) . q{ } . ${$self} },
|
|
fallback => 1;
|
|
|
|
sub new {
|
|
my ( $class, $value ) = @_;
|
|
return bless \$value, $class;
|
|
}
|
|
}
|
|
|
|
# This function converts hash-map keys back into full objects
|
|
|
|
sub thaw_key {
|
|
my ($key) = @_;
|
|
my ( $class, $value ) = split m/[ ]/, $key, 2;
|
|
return $class->new($value);
|
|
}
|
|
|
|
{
|
|
|
|
package Mal::Nil;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
|
|
# Allow nil to be treated as an empty list or hash-map.
|
|
use overload '@{}' => sub { [] }, '%{}' => sub { {} }, fallback => 1;
|
|
|
|
}
|
|
{
|
|
|
|
package Mal::True;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
{
|
|
|
|
package Mal::False;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
my $nil = Mal::Nil->new('nil');
|
|
my $true = Mal::True->new('true');
|
|
my $false = Mal::False->new('false');
|
|
sub nil { return $nil; }
|
|
sub true { return $true; }
|
|
sub false { return $false; }
|
|
|
|
{
|
|
|
|
package Mal::Integer;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
{
|
|
|
|
package Mal::Symbol;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
{
|
|
|
|
package Mal::String;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
{
|
|
|
|
package Mal::Keyword;
|
|
use parent -norequire, 'Mal::Scalar';
|
|
}
|
|
|
|
# Sequences
|
|
|
|
{
|
|
|
|
package Mal::Sequence;
|
|
use parent -norequire, 'Mal::Type';
|
|
|
|
sub new {
|
|
my ( $class, $data ) = @_;
|
|
return bless $data, $class;
|
|
}
|
|
|
|
sub clone {
|
|
my $self = shift;
|
|
return ref($self)->new( [ @{$self} ] );
|
|
}
|
|
}
|
|
|
|
# Lists
|
|
|
|
{
|
|
|
|
package Mal::List;
|
|
use parent -norequire, 'Mal::Sequence';
|
|
}
|
|
|
|
# Vectors
|
|
|
|
{
|
|
|
|
package Mal::Vector;
|
|
use parent -norequire, 'Mal::Sequence';
|
|
}
|
|
|
|
# Hash-maps
|
|
|
|
{
|
|
|
|
package Mal::HashMap;
|
|
use parent -norequire, 'Mal::Type';
|
|
|
|
sub new {
|
|
my ( $class, $src ) = @_;
|
|
return bless $src, $class;
|
|
}
|
|
|
|
sub clone {
|
|
my $self = shift;
|
|
return ref($self)->new( { %{$self} } );
|
|
}
|
|
}
|
|
|
|
# Functions
|
|
|
|
{
|
|
|
|
package Mal::Callable;
|
|
use parent -norequire, 'Mal::Type';
|
|
|
|
sub new {
|
|
my ( $class, $data ) = @_;
|
|
return bless $data, $class;
|
|
}
|
|
|
|
sub clone {
|
|
my $self = shift;
|
|
return bless sub { goto &{$self} }, ref $self;
|
|
}
|
|
}
|
|
|
|
{
|
|
|
|
package Mal::Function;
|
|
use parent -norequire, 'Mal::Callable';
|
|
}
|
|
|
|
{
|
|
|
|
package Mal::Macro;
|
|
use parent -norequire, 'Mal::Callable';
|
|
}
|
|
|
|
# Atoms
|
|
|
|
{
|
|
|
|
package Mal::Atom;
|
|
use parent -norequire, 'Mal::Type';
|
|
|
|
sub new {
|
|
my ( $class, $val ) = @_;
|
|
return bless \$val, $class;
|
|
}
|
|
}
|
|
|
|
1;
|