perl/reader.pm

   1 package reader;
   2 use feature qw(switch);
   3 use strict;
   4 use warnings;
   5 use Exporter 'import';
   6 our @EXPORT_OK = qw( read_str );
   7
   8 use types qw($nil $true $false);
   9
  10 use Data::Dumper;
  11
  12 {
  13     package Reader;
  14     sub new  {
  15         my $class = shift;
  16         bless { position => 0, tokens => shift } => $class
  17     }
  18     sub next { my $self = shift; return $self->{tokens}[$self->{position}++] }
  19     sub peek { my $self = shift; return $self->{tokens}[$self->{position}] }
  20 }
  21
  22 sub tokenize {
  23     my($str) = @_;
  24     my @tokens = $str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g;
  25     return grep {not /^;|^$/} @tokens;
  26 }
  27
  28 sub read_atom {
  29     my($rdr) = @_;
  30     my $token = $rdr->next();
  31     given ($token) {
  32         when(/^-?[0-9]+$/) { return Integer->new($token) }
  33         when(/^"/) { return String->new(substr $token, 1, -1) }
  34         when(/^nil$/) { return $nil }
  35         when(/^true$/) { return $true }
  36         when(/^false$/) { return $false }
  37         default { return Symbol->new($token) }
  38     }
  39 }
  40
  41 sub read_list {
  42     my($rdr,$class,$start,$end) = @_;
  43     $start = $start || '(';
  44     $end = $end || ')';
  45
  46     my $token = $rdr->next();
  47     my @lst = ();
  48     if ($token ne $start) {
  49         die "expected '$start'";
  50     }
  51     while (($token = $rdr->peek()) ne $end) {
  52         if (! defined $token) {
  53             die "expected '$end', got EOF";
  54         }
  55         push(@lst, read_form($rdr));
  56     }
  57     $rdr->next();
  58     if ($class eq 'List') {
  59         return List->new(\@lst);
  60     } elsif ($class eq 'Vector') {
  61         return Vector->new(\@lst);
  62     } else {
  63         my $hsh = {};
  64         for(my $i=0; $i<$#lst; $i+=2) {
  65             my $str = $lst[$i];
  66             $hsh->{$$str} = $lst[$i+1];
  67         }
  68         return HashMap->new($hsh);
  69     }
  70 }
  71
  72 sub read_form {
  73     my($rdr) = @_;
  74     my $token = $rdr->peek();
  75     given ($token) {
  76         when(')') { die "unexpected ')'"; }
  77         when('(') { return read_list($rdr, 'List'); }
  78         when(']') { die "unexpected ']'"; }
  79         when('[') { return read_list($rdr, 'Vector', '[', ']'); }
  80         when('}') { die "unexpected '}'"; }
  81         when('{') { return read_list($rdr, 'HashMap', '{', '}'); }
  82         default  { return read_atom($rdr); }
  83     }
  84 }
  85
  86 sub read_str {
  87     my($str) = @_;
  88     my @tokens = tokenize($str);
  89     #print join(" / ", @tokens) . "\n";
  90     return read_form(Reader->new(\@tokens));
  91 }
  92
  93 #print Dumper(read_str("123"));
  94 #print Dumper(read_str("+"));
  95 #print Dumper(read_str("\"abc\""));
  96 #print Dumper(read_str("nil"));
  97 #print Dumper(read_str("true"));
  98 #print Dumper(read_str("false"));
  99 #print Dumper(read_str("(+ 2 3)"));
 100 #print Dumper(read_str("(foo 2 (3 4))"));
 101
 102 1;