util/grokprims.pl

   1 #!/usr/bin/perl
   2 use warnings;
   3 use strict;
   4
   5 while (<>) {
   6   last if /^initSyms = /;
   7 }
   8
   9 my %assoc = (
  10     spre  => 'special',
  11     pre   => 'prefix',
  12     post  => 'postfix',
  13     left  =>  'left-associative infix',
  14     right => 'right-associative infix',
  15     non   =>   'non-associative infix',
  16     list  => 'list infix',
  17     chain => 'chaining infix',
  18 );
  19
  20 my @ops;
  21
  22 while (<>) {
  23   last unless /^\\\\n[^"]/;
  24   chomp;
  25
  26   my (undef, $ret, $assoc, $name, $args) = split ' ', $_, 5;
  27
  28   $name =~ s/\\(.)/$1/g;
  29
  30   $args =~ m/\((.*)\)/ or die "Bad args spec";
  31   $args = $1;
  32
  33   my @args = split /, *| +/, $args;
  34
  35   if (exists $assoc{$assoc}) {
  36     $assoc = $assoc{$assoc};
  37   } else {
  38     $assoc = "FIXME: $assoc";
  39   }
  40
  41   push @ops, {name=>$name, ret=>$ret, assoc=>$assoc, args=>[@args], line=>$.}
  42 }
  43
  44 print '<?xml version="1.1" encoding="UTF-8" ?><html><body><table border="1">';
  45
  46
  47
  48 foreach my $op (sort
  49          {
  50            $a->{name} cmp $b->{name} or
  51              $a->{assoc} cmp $b->{assoc} or
  52                @{$a->{args}} <=> @{$b->{args}}} @ops
  53         ) {
  54
  55   my $example;
  56
  57   local $_=$op->{assoc};
  58   my $name = $op->{name};
  59   my $a0 = $op->{args}[0];
  60   my $a1 = $op->{args}[1];
  61   my $arity = 0+@{$op->{args}};
  62
  63   if (/prefix/) {
  64     if (($arity>1 and $a0 =~ s/:$//) or
  65         $arity==1) {
  66       $example = "\$$a0.$name(".join(', ', map {"\$$_"} @{$op->{args}}[1..$arity-1]).")<br />";
  67     }
  68     $example .= "$name(". join(', ', map {$a=$_; $a=~s/:$//; '$'.$a} @{$op->{args}}) .")";
  69   } elsif (/(list|chaining) infix/) {
  70     $example = "\$$a0 $name \$$a0 $name \$$a0";
  71   } elsif (/left-associative/ and $arity==2) {
  72     $example = "(\$$a0 $name \$$a1) $name \$$a1";
  73   } elsif (/left-associative/ and $arity==2) {
  74     $example = "HUH: left-associative with arity $arity";
  75   } elsif (/right-associative/) {
  76     $example = "\$$a0 $name (\$$a0 $name \$$a1)";
  77   } elsif (/non-associative/) {
  78     $example = "\$$a0 $name \$$a1";
  79   } elsif (/postfix/ and $arity == 1) {
  80     $example = "\$$a0$name";
  81   } elsif (/special/ and $arity == 1) {
  82     $example = "$name\$$a0 # ???";
  83   } else {
  84     $example = "$_ ($arity)";
  85   }
  86
  87   print "   <tr>";
  88   print "<td><tt>$example</tt></td>";
  89   print "<td>$op->{assoc}</td>";
  90   print "<td>$op->{ret}</td>";
  91   print "<td><tt>$op->{name}</tt></td>";
  92   print "<td>(</td>";
  93   print "<td><table border='1' width='100%'><tr>";
  94   foreach my $arg (@{$op->{args}}) {
  95     print "<td>$arg</td>";
  96   }
  97   print "</td></tr></table>";
  98   print "<td>)</td>";
  99 #  print "<td>Prim.hs line $op->{line}</td>";
 100   print "</tr>\n";
 101 }
 102
 103 print "</table></body></html>";