# PIL1 will go away in the hopefully not too distant future.
# So this is all throw-away code.
use strict;
package PIL::PIL1CPerl5::NodesList;
my $list;
sub get_name_rep_type_pairs_list { $list }

sub hlp {
    my($rep,$type,$name,@pairs)=@_;
    push(@$list,[$name,$rep,$type,@pairs]);
}
sub node_s { hlp('string',@_); }
sub node_a { hlp('array1',@_); }
sub node_a2{ hlp('array2',@_); }
sub node_h { hlp('hash',@_); }

BEGIN{
node_h 'PIL_Environment',      'PIL_Environment', 
  'pilGlob' ,'[PIL_Decl]',
  'pilMain' ,'PIL_Stmts';

node_s 'PIL_Stmts',            'PNil';
node_h 'PIL_Stmts',            'PStmts', 
  'pStmt'  ,'PIL_Stmt',
  'pStmts' ,'PIL_Stmts';
node_h 'PIL_Stmts',            'PPad', 
  'pScope' ,'Scope',
  'pSyms'  ,'[(VarName, PIL_Expr)]',
  'pStmts' ,'PIL_Stmts';

node_s 'PIL_Stmt',             'PNoop';
node_h 'PIL_Stmt',             'PStmt', 
  'pExpr' ,'PIL_Expr';
node_h 'PIL_Stmt',             'PPos', 
  'pPos'  ,'Pos',
  'pExp'  ,'Exp',
  'pNode' ,'PIL_Stmt';

node_h 'PIL_Expr',             'PRawName', 
  'pRawName' ,'VarName';
node_h 'PIL_Expr',             'PExp', 
  'pLV'   ,'PIL_LValue';
node_h 'PIL_Expr',             'PLit', 
  'pLit'  ,'PIL_Literal';
node_h 'PIL_Expr',             'PThunk', 
  'pThunk' ,'PIL_Expr';
node_h 'PIL_Expr',             'PCode', 
  'pType'    ,'SubType',
  'pParams'  ,'[TParam]',
  'pLValue'  ,'Bool',
  'pIsMulti' ,'Bool',
  'pBody'    ,'PIL_Stmts';

node_h 'PIL_Decl',             'PSub', 
  'pSubName'    ,'SubName',
  'pSubType'    ,'SubType',
  'pSubParams'  ,'[TParam]',
  'pSubLValue'  ,'Bool',
  'pSubIsMulti' ,'Bool',
  'pSubBody'    ,'PIL_Stmts';

node_h 'PIL_Literal',          'PVal', 
  'pVal'  ,'Val';

node_h 'PIL_LValue',           'PVar', 
  'pVarName' ,'VarName';
node_h 'PIL_LValue',           'PApp', 
  'pCxt'  ,'TCxt',
  'pFun'  ,'PIL_Expr',
  'pInv'  ,'Maybe PIL_Expr',
  'pArgs' ,'[PIL_Expr]';
node_h 'PIL_LValue',           'PAssign', 
  'pLHS'  ,'[PIL_LValue]',
  'pRHS'  ,'PIL_Expr';
node_h 'PIL_LValue',           'PBind', 
  'pLHS'  ,'[PIL_LValue]',
  'pRHS'  ,'PIL_Expr';

node_h 'TParam',               'MkTParam', 
  'tpParam'   ,'Param',
  'tpDefault' ,'Maybe PIL_Expr';

node_s 'TCxt',                 'TCxtVoid';
node_a 'TCxt',                 'TCxtLValue',
  'type' ,'Type';
node_a 'TCxt',                 'TCxtItem',
  'type' ,'Type';
node_a 'TCxt',                 'TCxtSlurpy',
  'type' ,'Type';
node_a 'TCxt',                 'TTailCall',
  'tcxt' ,'TCxt';

node_h 'TEnv',                 'MkTEnv', 
  'tLexDepth' ,'Int',
  'tTokDepth' ,'Int',
  'tCxt'      ,'TCxt',
  'tReg'      ,'(TVar (Int, String))',
  'tLabel'    ,'(TVar (Int))';


node_s 'Scope', 'SState';
node_s 'Scope', 'SMy';
node_s 'Scope', 'SOur';
node_s 'Scope', 'SLet';
node_s 'Scope', 'STemp';
node_s 'Scope', 'SGlobal';

node_s 'SubType', 'SubMethod';
node_s 'SubType', 'SubCoroutine';
node_s 'SubType', 'SubMacro';
node_s 'SubType', 'SubRoutine';
node_s 'SubType', 'SubBlock';
node_s 'SubType', 'SubPointy';
node_s 'SubType', 'SubPrim';

node_s 'Val', 'VUndef';
node_a 'Val', 'VBool' , 'value' ,'unk';
node_a 'Val', 'VInt'  , 'value' ,'unk';
node_a 'Val', 'VRat'  , 'value' ,'unk';
node_a 'Val', 'VNum'  , 'value' ,'unk';
node_a 'Val', 'VStr'  , 'value' ,'unk';
node_a 'Val', 'VList' , 'value' ,'unk';
node_a 'Val', 'VType' , 'value' ,'unk';

node_s 'Cxt', 'CxtVoid';
node_a 'Cxt', 'CxtItem'   , 'type' ,'Type';
node_a 'Cxt', 'CxtSlurpy' , 'type' ,'Type';

node_a 'Type', 'MkType',
  'typename', 'String';
node_a2 'Type', 'TypeOr',
  'lhs' ,'Type',
  'rhs' ,'Type';
node_a2 'Type', 'TypeAnd',
  'lhs' ,'Type',
  'rhs' ,'Type';

node_h 'Param', 'MkParam',
  'isInvocant'   ,'Bool',
  'isOptional'   ,'Bool',
  'isNamed'      ,'Bool',
  'isLValue'     ,'Bool',
  'isWritable'   ,'Bool',
  'isLazy'       ,'Bool',
  'paramName'    ,'String',
  'paramContext' ,'Cxt',
  'paramDefault' ,'Exp';

node_h 'Pos', 'MkPos',
  'posName'        ,'String',
  'posBeginLine'   ,'Int',
  'posBeginColumn' ,'Int',
  'posEndLine'     ,'Int',
  'posEndColumn'   ,'Int';
}

package PIL::PIL1CPerl5::NodesInfo::Object;
sub new {
    my($cls,$name,$rep,$type,$pairs)=@_;
    my @fields;
    my %field_type;
    for(my $i=0; $i < @$pairs; $i+=2) {
        my($fname,$ftype)=($pairs->[$i],$pairs->[$i+1]);
        push(@fields,$fname);
        $field_type{$fname} = $ftype;
    }
    my $self = {
        name => $name,
        rep  => $rep,
        type => $type,
        pairs => $pairs,
        fields => \@fields,
        field_type => \%field_type,
    };
    bless $self,$cls;
    $self;
}
sub rep_type  { $_[0]{'rep'} } # string array1 array2 hash
sub field_is_array {
    my($self,$fname)=@_;
    $self->{'field_type'}{$fname} =~ /^\[/ ? 1 : 0;
}
sub field_is_optional {
    my($self,$fname)=@_;
    $self->{'field_type'}{$fname} =~ /Maybe/ ? 1 : 0;
}
sub field_is_node {
    my($self,$fname)=@_;
    ($self->{'field_type'}{$fname} =~ /^(\w+)/
     && defined $PIL::PIL1CPerl5::NodesInfo::node_named{$1});
}
sub field_type_simple {
    my($self,$fname)=@_;
    my $ftype = $self->{'field_type'}{$fname};
    $ftype =~ s/Mabye //;
    $ftype =~ s/[\[\]]//g;
    $ftype;
}
# XXX - not sure what to do about TVar and pSyms.
package PIL::PIL1CPerl5::NodesInfo;
our %node_named;
our @nodes;
our %nodes_of_type;
sub init {
    my $list = PIL::PIL1CPerl5::NodesList::get_name_rep_type_pairs_list();
    my $code = "";
    for (@$list) {
        my($name,$rep,$type,@pairs)=@$_;
        my $o = PIL::PIL1CPerl5::NodesInfo::Object->new($name,$rep,$type,\@pairs);
        $node_named{$name} = $o;
        push(@nodes,$o);
        push(@{$nodes_of_type{$type}},$o);
    }
}
BEGIN{&init();}

package PIL::PIL1::NodeSet0;
sub gen_code {
    my($pkg_root)=@_;
    $pkg_root = 'PIL::PIL1::NodeSet0' if !$pkg_root;
    my $code = "";
    my(%created,%used);
    for my $n (@PIL::PIL1CPerl5::NodesInfo::nodes) {
        my $name = $n->{'name'};
        my $rep = ucfirst $n->rep_type;
        my $type = $n->{'type'};
	my $pkg_this = "${pkg_root}::$name";
	my $pkg_type = "${pkg_root}::$type";
	my $pkg_rep  = "${pkg_root}::NodeRep$rep";
	my $pkg_node = "${pkg_root}::Node";
	$pkg_type = "" if $pkg_type eq $pkg_this;
	$used{$pkg_type}=1 if $pkg_type;
	$used{$pkg_rep}=1;
	$used{$pkg_node}=1;
	$created{$pkg_this}=1;
        $code .= <<END;

package $pkg_this;
       \@${pkg_root}::${name}::ISA=qw(
          $pkg_type
          $pkg_rep
          $pkg_node);
{ my \$info = \$PIL::PIL1CPerl5::NodesInfo::node_named{'$name'};
  sub info { \$info } }
sub name { '$name' }
END
    }
$code .= "package ${pkg_root}::Node;\n".<<'END';
sub is_slurpy { $_[0]->name =~ /Slurpy/ }
END
    foreach my $pkg (keys %used) {
	next if $created{$pkg};
	$code .= "package $pkg;\n";
    }
    #print $code;
    $code;
}
BEGIN{ eval(gen_code); die $@ if $@; }

package PIL::PIL1CPerl5::Util;
sub rebless_with_prefix {
    my($o,$prefix)=@_;
    my $ref = ref $o;
    return $o if !$ref;
    return $o if $ref eq 'Math::BigInt';
    if($ref !~ /^([A-Z]+)$/) {
	$ref =~ s/::/_/; # PIL::Environment :(
        $ref = "$prefix$ref";
        bless $o,'AvoidAnyOverloading'.int(rand(10000000));
    }
    my $s = "$o";
    if($s =~ /ARRAY/) {
        for (@$o) { rebless_with_prefix($_,$prefix) }
    } elsif($s =~ /HASH/) {
        for (values %$o) { rebless_with_prefix($_,$prefix) }
    } else {die "bug"}
    bless $o,$ref;
    return $o;
}
sub rebless_with_prefix_and_cleanup {
    my($o,$prefix)=@_;
    my $ref = ref $o;
    return $o if !$ref;
    return $o if $ref eq 'Math::BigInt';
    if($ref !~ /^([A-Z]+)$/) {
	$ref =~ s/::/_/; # PIL::Environment :(
        $ref = "$prefix$ref";
        bless $o,'AvoidAnyOverloading'.int(rand(10000000));
    }
    my $s = "$o";
    if($s =~ /ARRAY/) {
        for (@$o) {
	    rebless_with_prefix_and_cleanup($_,$prefix);
	}
    } elsif($s =~ /HASH/) {
        for (keys %$o) {
	    my $v = $$o{$_};
	    if(ref($v)) {
		rebless_with_prefix_and_cleanup($v,$prefix);
	    } elsif(defined $v) {
		$$o{$_} = "$prefix$v"
		    if $v =~ /^(PNil|PNoop|TCxtVoid|VUndef|CxtVoid)$/;
	    }
	}
    } else {die "bug"}
    bless $o,$ref;
    return $o;
}


package PIL::PIL1CPerl5::Unparse_CPerl5;
sub recurse {
    my($x)=@_;
    my $s;
    return '(undef)' if !defined $x;
    my $ref = ref($x);
    if($ref eq 'ARRAY') {
	$s = '['.join(",",map{recurse($_)}@$x).']';
    } elsif($ref) {
	$s = $x->unparse;
    } elsif($x !~ /^\d+(\.\d+)?$/s) {
	$x =~ s/([\$\@\%\\\"])/\\$1/g;
	$s = "\"$x\"";
    } else { $s = $x }
    $s;
}
sub PIL::PIL1::NodeSet0::NodeRepString::unparse {
    my $n = $_[0]->name; "\"$n\"";
}
sub PIL::PIL1::NodeSet0::NodeRepArray1::unparse {
    my $n = $_[0]->name;
    my $v0 = $_[0][0]; my $s = recurse($v0);
    $s = "\"$v0\"" if $n eq 'VStr' && $s !~ /\A\"/;
    "bless([$s] , \"$n\")";
}
sub PIL::PIL1::NodeSet0::NodeRepArray2::unparse {
    my $n = $_[0]->name;
    my $v0 = $_[0][0]; $v0 = recurse($v0);
    my $v1 = $_[0][1]; $v1 = recurse($v1);
    "bless([$v0,$v1] , \"$n\")";
}
sub PIL::PIL1::NodeSet0::NodeRepHash::unparse {
    my $n = $_[0]->name;
    my @kv;
    for my $k (@{$_[0]->info->{'fields'}}) {
        my $v = $_[0]{$k};
	die "bug" if !defined $_[0];
	next if defined($v) && $v eq $_[0]; # where does this recursion arise?
	my $v2 = recurse($v);
	$v2 = "\"$v\"" if $k eq 'posName' && $v2 !~ /\A\"/;
        push(@kv,"$k => ".$v2);
    }
    my $kv = join(",",@kv);
    "bless({$kv} , \"$n\")";
}

package PIL::PIL1CPerl5::Util::Hacks;
sub pil_diff {
    my(@c01)=@_;
    for(@c01) { s/ /\n/g; s/\n*\z/\n/; }
    my $tof = sub { open(F,">$_[0]") or die; print F $_[1];close F;};
    $tof->("deleteme_pil0",$c01[0]);
    $tof->("deleteme_pil1",$c01[1]);
    system("diff -u --minimal deleteme_pil0 deleteme_pil1");
}
sub p2p {
    my($fn)=@_;
    my $c0 = `cat $fn`;
    my $p = eval($c0); die "$fn: $@" if $@;
    PIL::PIL1CPerl5::Util::rebless_with_prefix($p,'PIL::PIL1::NodeSet0::');
    return if !defined $p;
    my $c1 = $p->unparse;
    $c1 =~ s/PIL_Environment/PIL::Environment/g;
    if($c0 ne $c1) { pil_diff($c0,$c1) }
}

package PIL::PIL1CPerl5::Util::FilterNodeDefs;
our($package_name,$method_name);
sub import {
    my($pkg,$name)=@_;
    $package_name = $pkg || '__PACKAGE__';
    $method_name = $name || 'emit';
}
sub gen {
    my($name,$vars,$body)=@_;

    my $info = $PIL::PIL1CPerl5::NodesInfo::node_named{$name};
    die "bug $name" if !$info;
    my $chk = join(", ",map {"\$$_"} @{$info->{'fields'}});
    $vars eq $chk || die "bug: node field list mismatch:\n$vars\n$chk\n";
    my $keys = join(" ", @{$info->{'fields'}});

    my $code = "";
    $code .= "sub ${package_name}::${name}::${method_name} {";

    my $rep = $info->rep_type;
    if($vars eq "") {}
    elsif($rep eq 'string') {}
    elsif($rep eq 'hash') {
	$code .= " my \$self=\$_[0];my($vars)=\@{\$self}{qw($keys)};";}
    else { # array
	$code .= " my \$self=\$_[0];my($vars)=\@{\$self};";}

    $code .= "$body}";
    $code;
}
use Filter::Simple sub {
    s/\#.+//g;
    s/^NODE\s+(\S+)\s+\(([^\)]*)\)\s+\{(.+?)(?:^\}|\}\s*?$)/gen($1,$2,$3)/mseg;
    s/\bDOWN\((.+?)\)/${1}->emit()/g;
    #s/\bLOOK\((.+?)\)//g;
    #print;
    #print STDERR;
    $_;
};
# BEGIN { FILTER_ONLY code => sub {} }; also works?

1;
__END__
#----------------------------------------------------------------------
What is Exp?  And why is it in my tree? :)