perl/reader.pm

   1 package reader;
   2 use feature qw(switch);
   3 use strict;
   4 use warnings FATAL => qw(all);
   5 use Exporter 'import';
   6 our @EXPORT_OK = qw( read_str );
   7
   8 use types qw($nil $true $false _hash_map);
   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 {! /^;|^$/} @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(/^"/) {
  34             my $str = substr $token, 1, -1;
  35             $str =~ s/\\"/"/g;
  36             $str =~ s/\\n/\n/g;
  37             return String->new($str)
  38         }
  39         when(/^nil$/) { return $nil }
  40         when(/^true$/) { return $true }
  41         when(/^false$/) { return $false }
  42         default { return Symbol->new($token) }
  43     }
  44 }
  45
  46 sub read_list {
  47     my($rdr,$class,$start,$end) = @_;
  48     $start = $start || '(';
  49     $end = $end || ')';
  50
  51     my $token = $rdr->next();
  52     my @lst = ();
  53     if ($token ne $start) {
  54         die "expected '$start'";
  55     }
  56     while (($token = $rdr->peek()) ne $end) {
  57         if (! defined $token) {
  58             die "expected '$end', got EOF";
  59         }
  60         push(@lst, read_form($rdr));
  61     }
  62     $rdr->next();
  63     if ($class eq 'List') {
  64         return List->new(\@lst);
  65     } elsif ($class eq 'Vector') {
  66         return Vector->new(\@lst);
  67     } else {
  68         return _hash_map(@lst);
  69     }
  70 }
  71
  72 sub read_form {
  73     my($rdr) = @_;
  74     my $token = $rdr->peek();
  75     given ($token) {
  76         when("'") { $rdr->next(); List->new([Symbol->new('quote'),
  77                                              read_form($rdr)]) }
  78         when('`') { $rdr->next(); List->new([Symbol->new('quasiquote'),
  79                                              read_form($rdr)]) }
  80         when('~') { $rdr->next(); List->new([Symbol->new('unquote'),
  81                                              read_form($rdr)]) }
  82         when('~@') { $rdr->next(); List->new([Symbol->new('splice-unquote'),
  83                                               read_form($rdr)]) }
  84         when(')') { die "unexpected ')'" }
  85         when('(') { return read_list($rdr, 'List') }
  86         when(']') { die "unexpected ']'" }
  87         when('[') { return read_list($rdr, 'Vector', '[', ']') }
  88         when('}') { die "unexpected '}'" }
  89         when('{') { return read_list($rdr, 'HashMap', '{', '}') }
  90         default  { return read_atom($rdr) }
  91     }
  92 }
  93
  94 sub read_str {
  95     my($str) = @_;
  96     my @tokens = tokenize($str);
  97     #print join(" / ", @tokens) . "\n";
  98     return read_form(Reader->new(\@tokens));
  99 }
 100
 101 #print Dumper(read_str("123"));
 102 #print Dumper(read_str("+"));
 103 #print Dumper(read_str("\"abc\""));
 104 #print Dumper(read_str("nil"));
 105 #print Dumper(read_str("true"));
 106 #print Dumper(read_str("false"));
 107 #print Dumper(read_str("(+ 2 3)"));
 108 #print Dumper(read_str("(foo 2 (3 4))"));
 109
 110 1;