perl/printer.pm

   1 package printer;
   2 use strict;
   3 use warnings FATAL => qw(all);
   4 use feature qw(switch);
   5 use Exporter 'import';
   6 our @EXPORT_OK = qw( _pr_str );
   7
   8 use types qw($nil $true $false);
   9
  10 use Data::Dumper;
  11
  12 sub _pr_str {
  13     my($obj, $print_readably) = @_;
  14     my($_r) = (defined $print_readably) ? $print_readably : 1;
  15     given (ref $obj) {
  16         when(/^List/) {
  17             return '(' . join(' ', map {_pr_str($_, $_r)} @{$obj->{val}}) . ')';
  18         }
  19         when(/^Vector/) {
  20             return '[' . join(' ', map {_pr_str($_, $_r)} @{$obj->{val}}) . ']';
  21         }
  22         when(/^HashMap/) {
  23             my @elems = ();
  24             foreach my $key (keys $obj->{val}) {
  25                 push(@elems, _pr_str(String->new($key), $_r));
  26                 push(@elems, _pr_str($obj->{val}->{$key}, $_r));
  27             }
  28
  29             return '{' . join(' ', @elems) . '}';
  30         }
  31         when(/^String/) {
  32             if ($_r) {
  33                 my $str = $$obj;
  34                 $str =~ s/\\/\\\\/g;
  35                 $str =~ s/"/\\"/g;
  36                 $str =~ s/\n/\\n/g;
  37                 return '"' . $str . '"';
  38             } else {
  39                 return $$obj;
  40             }
  41         }
  42         when(/^Function/) {
  43             return '<fn* ' . _pr_str($obj->{params}) .
  44                    ' ' . _pr_str($obj->{ast}) . '>';
  45         }
  46         when(/^Atom/) {
  47             return '(atom ' . _pr_str($obj->{val}) . ")";
  48         }
  49         when(/^CODE/)   { return '<builtin_fn* ' . $obj . '>'; }
  50         default         { return $$obj; }
  51     }
  52 }
  53
  54 1;