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);
   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         my $hsh = {};
  69         for(my $i=0; $i<$#lst; $i+=2) {
  70             my $str = $lst[$i];
  71             $hsh->{$$str} = $lst[$i+1];
  72         }
  73         return HashMap->new($hsh);
  74     }
  75 }
  76
  77 sub read_form {
  78     my($rdr) = @_;
  79     my $token = $rdr->peek();
  80     given ($token) {
  81         when("'") { $rdr->next(); List->new([Symbol->new('quote'),
  82                                              read_form($rdr)]) }
  83         when('`') { $rdr->next(); List->new([Symbol->new('quasiquote'),
  84                                              read_form($rdr)]) }
  85         when('~') { $rdr->next(); List->new([Symbol->new('unquote'),
  86                                              read_form($rdr)]) }
  87         when('~@') { $rdr->next(); List->new([Symbol->new('splice-unquote'),
  88                                               read_form($rdr)]) }
  89         when(')') { die "unexpected ')'" }
  90         when('(') { return read_list($rdr, 'List') }
  91         when(']') { die "unexpected ']'" }
  92         when('[') { return read_list($rdr, 'Vector', '[', ']') }
  93         when('}') { die "unexpected '}'" }
  94         when('{') { return read_list($rdr, 'HashMap', '{', '}') }
  95         default  { return read_atom($rdr) }
  96     }
  97 }
  98
  99 sub read_str {
 100     my($str) = @_;
 101     my @tokens = tokenize($str);
 102     #print join(" / ", @tokens) . "\n";
 103     return read_form(Reader->new(\@tokens));
 104 }
 105
 106 #print Dumper(read_str("123"));
 107 #print Dumper(read_str("+"));
 108 #print Dumper(read_str("\"abc\""));
 109 #print Dumper(read_str("nil"));
 110 #print Dumper(read_str("true"));
 111 #print Dumper(read_str("false"));
 112 #print Dumper(read_str("(+ 2 3)"));
 113 #print Dumper(read_str("(foo 2 (3 4))"));
 114
 115 1;