perl/reader.pm

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