perl/printer.pm

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