perl/core.pm

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