perl/core.pm

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