impls/perl/core.pm

   1 package core;
   2 use strict;
   3 use warnings;
   4
   5 use Data::Dumper;
   6 use Hash::Util qw(fieldhash);
   7 use List::Util qw(pairmap);
   8 use Time::HiRes qw(time);
   9
  10 use readline;
  11 use types qw(_equal_Q thaw_key $nil $true $false);
  12 use reader qw(read_str);
  13 use printer qw(_pr_str);
  14 use interop qw(pl_to_mal);
  15
  16 # String functions
  17
  18 sub pr_str {
  19     return Mal::String->new(join(" ", map {_pr_str($_, 1)} @_));
  20 }
  21
  22 sub str {
  23     return Mal::String->new(join("", map {_pr_str($_, 0)} @_));
  24 }
  25
  26 sub prn {
  27     print join(" ", map {_pr_str($_, 1)} @_) . "\n";
  28     return $nil
  29 }
  30
  31 sub println {
  32     print join(" ", map {_pr_str($_, 0)} @_) . "\n";
  33     return $nil
  34 }
  35
  36 sub mal_readline {
  37     my $line = readline::mal_readline(${$_[0]});
  38     return defined $line ? Mal::String->new($line) : $nil;
  39 }
  40
  41 sub slurp {
  42     use autodie;
  43     open(my $fh, '<', ${$_[0]});
  44     my $data = do { local $/; <$fh> };
  45     Mal::String->new($data)
  46 }
  47
  48 # Hash Map functions
  49
  50 sub assoc {
  51     my $src_hsh = shift;
  52     return Mal::HashMap->new( { %$src_hsh, @_ } );
  53 }
  54
  55 sub dissoc {
  56     my $new_hsh = { %{shift @_} };
  57     delete @{$new_hsh}{@_};
  58     return Mal::HashMap->new($new_hsh);
  59 }
  60
  61
  62 sub get {
  63     my ($hsh, $key) = @_;
  64     return $hsh->{$key} // $nil;
  65 }
  66
  67 sub contains_Q {
  68     my ($hsh, $key) = @_;
  69     return (exists $hsh->{$key}) ? $true : $false;
  70 }
  71
  72 sub mal_keys {
  73     my @ks = map { thaw_key($_) } keys %{$_[0]};
  74     return Mal::List->new(\@ks);
  75 }
  76
  77 sub mal_vals {
  78     my @vs = values %{$_[0]};
  79     return Mal::List->new(\@vs);
  80 }
  81
  82
  83 # Sequence functions
  84
  85 sub cons {
  86     my ($a, $b) = @_;
  87     Mal::List->new([$a, @$b]);
  88 }
  89
  90 sub nth {
  91     my ($seq,$i) = @_;
  92     return $seq->[$i] // die "nth: index out of bounds";
  93 }
  94
  95 sub first {
  96     my ($seq) = @_;
  97     return $seq->[0] // $nil;
  98 }
  99
 100 sub apply {
 101     my $f = shift;
 102     push @_, @{pop @_};
 103     goto &$f;
 104 }
 105
 106 sub mal_map {
 107     my $f = shift;
 108     my @arr = map { &$f($_) } @{$_[0]};
 109     return Mal::List->new(\@arr);
 110 }
 111
 112 sub conj {
 113     my $seq = shift;
 114     my $new_seq = $seq->clone;
 115     if ($new_seq->isa('Mal::List')) {
 116         unshift @$new_seq, reverse @_;
 117     } else {
 118         push @$new_seq, @_;
 119     }
 120     return $new_seq;
 121 }
 122
 123 sub seq {
 124     my ($arg) = @_;
 125     if ($arg eq $nil) {
 126         return $nil;
 127     } elsif ($arg->isa('Mal::List')) {
 128         return $nil unless @$arg;
 129         return $arg;
 130     } elsif ($arg->isa('Mal::Vector')) {
 131         return $nil unless @$arg;
 132         return Mal::List->new([@$arg]);
 133     } elsif ($arg->isa('Mal::String')) {
 134         return $nil if length($$arg) == 0;
 135         my @chars = map { Mal::String->new($_) } split(//, $$arg);
 136         return Mal::List->new(\@chars);
 137     } else {
 138         die "seq requires list or vector or string or nil";
 139     }
 140 }
 141
 142 fieldhash my %meta;
 143
 144 # Metadata functions
 145 sub with_meta {
 146     my $new_obj = $_[0]->clone;
 147     $meta{$new_obj} = $_[1];
 148     return $new_obj;
 149 }
 150
 151
 152 # Atom functions
 153 sub swap_BANG {
 154     my ($atm,$f,@args) = @_;
 155     return $$atm = &$f($$atm, @args);
 156 }
 157
 158
 159 # Interop
 160
 161 sub pl_STAR {
 162     my $result = eval(${$_[0]});
 163     die $@ if $@;
 164     return pl_to_mal($result);
 165 }
 166
 167
 168
 169 %core::ns = (
 170     '='           => sub { _equal_Q($_[0], $_[1]) ? $true : $false },
 171     'throw'       => sub { die $_[0] },
 172     'nil?'        => sub { $_[0] eq $nil ? $true : $false },
 173     'true?'       => sub { $_[0] eq $true ? $true : $false },
 174     'false?'      => sub { $_[0] eq $false ? $true : $false },
 175     'number?'     => sub { $_[0]->isa('Mal::Integer') ? $true : $false },
 176     'symbol'      => sub { Mal::Symbol->new(${$_[0]}) },
 177     'symbol?'     => sub { $_[0]->isa('Mal::Symbol') ? $true : $false },
 178     'string?'     => sub { $_[0]->isa('Mal::String') ? $true : $false },
 179     'keyword'     => sub { Mal::Keyword->new(${$_[0]}) },
 180     'keyword?'    => sub { $_[0]->isa('Mal::Keyword') ? $true : $false },
 181     'fn?'         => sub { $_[0]->isa('Mal::Function') ? $true : $false },
 182     'macro?'      => sub { $_[0]->isa('Mal::Macro') ? $true : $false },
 183
 184     'pr-str'      => \&pr_str,
 185     'str'         => \&str,
 186     'prn'         => \&prn,
 187     'println'     => \&println,
 188     'readline'    => \&mal_readline,
 189     'read-string' => sub { read_str(${$_[0]}) },
 190     'slurp'       => \&slurp,
 191     '<'           => sub { ${$_[0]} <  ${$_[1]} ? $true : $false },
 192     '<='          => sub { ${$_[0]} <= ${$_[1]} ? $true : $false },
 193     '>'           => sub { ${$_[0]} >  ${$_[1]} ? $true : $false },
 194     '>='          => sub { ${$_[0]} >= ${$_[1]} ? $true : $false },
 195     '+'           => sub { Mal::Integer->new(${$_[0]} + ${$_[1]}) },
 196     '-'           => sub { Mal::Integer->new(${$_[0]} - ${$_[1]}) },
 197     '*'           => sub { Mal::Integer->new(${$_[0]} * ${$_[1]}) },
 198     '/'           => sub { Mal::Integer->new(${$_[0]} / ${$_[1]}) },
 199     'time-ms'     => sub { Mal::Integer->new(int(time()*1000)) },
 200
 201     'list'        => sub { Mal::List->new(\@_) },
 202     'list?'       => sub { $_[0]->isa('Mal::List') ? $true : $false },
 203     'vector'      => sub { Mal::Vector->new(\@_) },
 204     'vector?'     => sub { $_[0]->isa('Mal::Vector') ? $true : $false },
 205     'hash-map'    => sub { Mal::HashMap->new(\@_) },
 206     'map?'        => sub { $_[0]->isa('Mal::HashMap') ? $true : $false },
 207     'assoc'       => \&assoc,
 208     'dissoc'      => \&dissoc,
 209     'get'         => \&get,
 210     'contains?'   => \&contains_Q,
 211     'keys'        => \&mal_keys,
 212     'vals'        => \&mal_vals,
 213
 214     'sequential?' => sub { $_[0]->isa('Mal::Sequence') ? $true : $false },
 215     'nth'         => sub { nth($_[0], ${$_[1]}) },
 216     'first'       => \&first,
 217     'rest'        => sub { $_[0]->rest() },
 218     'cons'        => \&cons,
 219     'concat'      => sub { Mal::List->new([map @$_, @_]) },
 220     'vec'         => sub { Mal::Vector->new([@{$_[0]}]) },
 221     'empty?'      => sub { @{$_[0]} ? $false : $true },
 222     'count'       => sub { Mal::Integer->new(scalar(@{$_[0]})) },
 223     'apply'       => \&apply,
 224     'map'         => \&mal_map,
 225     'conj'        => \&conj,
 226     'seq'         => \&seq,
 227
 228     'with-meta'   => \&with_meta,
 229     'meta'        => sub { $meta{$_[0]} // $nil },
 230     'atom'        => sub { Mal::Atom->new($_[0]) },
 231     'atom?'       => sub { $_[0]->isa('Mal::Atom') ? $true : $false },
 232     'deref'       => sub { ${$_[0]} },
 233     'reset!'      => sub { ${$_[0]} = $_[1] },
 234     'swap!'       => \&swap_BANG,
 235
 236     'pl*'         => \&pl_STAR,
 237 );
 238
 239 foreach my $f (values %core::ns) {
 240     $f = Mal::Function->new($f);
 241 }
 242
 243 1;