#!/usr/bin/perl -w

use strict;
use warnings;
use Data::Dumper;

open OP, "<data/operators.txt";

my @fl;
my @in;

my @add;
my %stuff;

my %oper_map = (
    "-" => "Sub",
    "+" => "Add",
    "*" => "Mul",
    "u-" => "Sub",
    "u+" => "Add",
    "u*" => "Mul",
    "f*" => "FMul",
    "f-" => "FSub",
    "f+" => "FAdd",
    "==" => "Eq",
    "!=" => "NEq",
    ">" => "Gt",
    ">=" => "Gte",
    "<" => "Lt",
    "<=" => "Lte",
    "u==" => "Eq",
    "u!=" => "NEq",
    "u>" => "UGt",
    "u>=" => "UGte",
    "u<" => "ULt",
    "u<=" => "ULte",

    "&" => "And",
    "|" => "Or",
    "^" => "Xor",
    "<<" => "Shl",
    ">>" => "Shra",
    "u>>" => "Shr",
    "/" => "Div",
    "%" => "Mod",
    "u/" => "UDiv",
    "u%" => "UMod",
    "u&" => "And",
    "u|" => "Or",
    "u^" => "Xor",
    "u<<" => "Shl",


    "f==" => "FEq",
    "f!=" => "FNEq",
    "f>" => "FGt",
    "f>=" => "FGte",
    "f<" => "FLt",
    "f<=" => "FLte",

    "_-" => "Neg",
    "_~" => "Com",
    "u_-" => "Neg",
    "u_~" => "Com",
    "f_-" => "FNeg"

    );

sub vtype {
    ($_) = @_ if @_;
    return 'u' if /^u/;
    return ''  if /^s/;
    return 'f' if /^f/;
}

while(<OP>) {
    chomp;
    next unless /\S/;
    next if /^\s*#/;
    if (/^\[([\w,\s]*)\]\s*$/) {
        @add = split(/\s*,\s*/,$1);
        next;
    }
    my @a = split /\s*,\s*/;
    foreach my $y (@add) {
        push @{$stuff{$y}}, \@a;
    }
}

my @ds;
open PR, "<data/primitives.txt";
while(<PR>) {
    chomp;
    next unless /\S/;
    next if /^\s*#/;
    my @a = split /\s*,\s*/;
    push @ds, \@a;
}

#print Dumper(\@fl,\@in,\@ds);

my @inst;
my @meth;
my @cmeth;
my @names;
my %seen;

sub const($$$@) {
    my ($cn,$v,$t,$ct) = @_;
    $ct ||= "int";
    my $ctn = $ct;
    $ctn =~ s/\W/_/g;

    if ($v =~ /^\d/) {
        return "prim_number $cn $v r_$ctn $t";
    } else {
        return "prim_const $cn \"$v\" r_$ctn \"$ct\" $t";
    }
}

#print STDERR Dumper(\%stuff);

my %tcon;
sub tcon($) {
    return $tcon{$_[0]}[0] if $tcon{$_[0]};
    my $n = $_[0];
    $n =~ s/\W/_/g;
    $n = "t_" . $n;
    my $x = $_[0];
    $x =~ s/^.*\.//;
    my $v = "$n = ELit litCons { litName = tc_$x, litType = eStar}";
    $tcon{$_[0]} = [$n,$v];
    return $n;
}

my %rtype;
sub rtype($) {
    return $rtype{$_[0]}[0] if $rtype{$_[0]};
    my $c = $_[0];
    $c =~ s/\W/_/g;
    my $n = "r_" . $c;
    my $v = "$n " . " "x(14-length $n) . "= ELit litCons { litName = rt_$c, litType = eHash }";
    $rtype{$_[0]} = [$n,$v];
    return $n;
}

my %dcon;
sub dcon($) {
    my $x = $_[0];
    $x =~ s/^.*\.//;
    return "dc_$x";
}

my %hsname;
sub hsname($) {
    return $hsname{$_[0]}[0] if $hsname{$_[0]};
    my $n = $_[0];
    $n =~ s/\W/_/g;
    $n = "n_" . $n;
    my $v = "$n = toClassName \"$_[0]\"";
    $hsname{$_[0]} = [$n,$v];
    return $n;
}

my %tycon;
sub tycon($) {
    return $tycon{$_[0]}[0] if $tycon{$_[0]};
    my $n = $_[0];
    $n =~ s/\W/_/g;
    $n = "tc_" . $n;
    my $x = $_[0];
    $x =~ s/^.*\.//;
    my $v = "$n = TCon (Tycon tc_$x kindStar)";
    $tycon{$_[0]} = [$n,$v];
    return $n;
}

foreach my $d (@ds) {
    #my @cs = ($d->[2] =~ /int/) ? @in : @fl;
    my $vtype = vtype $d->[1];
    #print STDERR "$d->[1] - '$vtype'\n";
    my @cs = @{$stuff{$d->[2]}};
    my $t = tcon($d->[0]);
    $d->[1] =~ s/^[us]//;
    my $rtype = rtype($d->[1]);
    #my $t =  "(ELit (LitCons (parseName TypeConstructor \"$d->[0]\") [] eStar) )";
    #my $t =  "(ELit (LitCons $nn [] eStar) )";
    my $tycon = tycon($d->[0]);
    my $cncons = dcon($d->[0]);
    my $prelude_bounded = hsname("Jhc.Enum.Bounded");
    my $foreign_storable = hsname("Foreign.Storable.Storable");
    my $c_num = hsname("Jhc.Num.Num");
    push @inst, "[] :=> IsIn $prelude_bounded $tycon" if $vtype ne 'f';
    push @inst, "[] :=> IsIn $foreign_storable $tycon";
    push @cmeth, "($foreign_storable, toInstName \"Foreign.Storable.sizeOf.$d->[0]\", ELam (v0 $t) \$ prim_sizeof \"$d->[1]\")";
    push @cmeth, "($foreign_storable, toInstName \"Foreign.Storable.poke.$d->[0]\", buildPoke $cncons $t \"$d->[1]\")";
    push @cmeth, "($foreign_storable, toInstName \"Foreign.Storable.peek.$d->[0]\", buildPeek $cncons $t \"$d->[1]\")";
    push @cmeth, "($prelude_bounded, toInstName \"Jhc.Enum.maxBound.$d->[0]\", " . "prim_${vtype}maxbound $cncons $t \"$d->[1]\")" if $vtype ne 'f';;
    push @cmeth, "($prelude_bounded, toInstName \"Jhc.Enum.minBound.$d->[0]\", " . "prim_${vtype}minbound $cncons $t \"$d->[1]\")" if $vtype ne 'f';;
    my $ivar = "v2_Int";
    my $ivart = "v2_Integer";
    my $tvar = "(v2 $t)";
    if ($d->[0] eq "Jhc.Prim.Int") {
        push @cmeth, "($c_num, toInstName \"Jhc.Num.fromInt.$d->[0]\", ELam $ivar (EVar $ivar))";
        push @cmeth, "($c_num, toInstName \"Jhc.Num.toInt.$d->[0]\", ELam $ivar (EVar $ivar))";
    } else {
        push @cmeth, "($c_num, toInstName \"Jhc.Num.fromInt.$d->[0]\", ELam $ivar (create_${vtype}integralCast_fromInt $cncons $rtype (EVar $ivar) $t))";
        push @cmeth, "($c_num, toInstName \"Jhc.Num.toInt.$d->[0]\", ELam $tvar (create_${vtype}integralCast_toInt $cncons $rtype (EVar $tvar)))" if $d->[2] =~ /int/ ;
    }
    if ($d->[0] eq "Jhc.Basics.Integer") {
        push @cmeth, "($c_num, toInstName \"Jhc.Num.fromInteger.$d->[0]\", ELam $ivart (EVar $ivart))";
        push @cmeth, "($c_num, toInstName \"Jhc.Num.toInteger.$d->[0]\", ELam $ivart (EVar $ivart))";
    } else {
        push @cmeth, "($c_num, toInstName \"Jhc.Num.fromInteger.$d->[0]\", ELam $ivart (create_${vtype}integralCast_fromInteger $cncons $rtype (EVar $ivart) $t))";
        push @cmeth, "($c_num, toInstName \"Jhc.Num.toInteger.$d->[0]\", ELam $tvar (create_${vtype}integralCast_toInteger $cncons $rtype (EVar $tvar)))" if $d->[2] =~ /int/ ;
    }
    push @cmeth, "($c_num, toInstName \"Jhc.Num.abs.$d->[0]\", ELam $tvar (build_${vtype}abs \"$d->[1]\" $cncons (EVar $tvar)  ))";
    push @cmeth, "($c_num, toInstName \"Jhc.Num.signum.$d->[0]\", ELam $tvar (build_${vtype}signum \"$d->[1]\" $cncons (EVar $tvar) ))";
    #push @names, "(\"$d->[0]\", \"$d->[1]\", \"$d->[2]\")\n";
    my $sname = $d->[0];
    $sname =~ s/^.*\.//;
    push @names, "(dc_$sname, tc_$sname, " . rtype($d->[1]) . ", \"$d->[1]\", \"$d->[2]\")\n";
    foreach my $c (@cs) {
        my $tycon = tycon($d->[0]);
        my $nn = hsname($c->[2]);
        push @inst, "[] :=> IsIn $nn $tycon" unless $seen{$c->[2],$d->[0]}++;
        my $x = $c->[2];
        $x =~ s/^([\w.]+\.).*$/$1/;
        if ($c->[0] =~ /^a[aI][aIB]$/) {
            push @cmeth, "($nn,toInstName \"$x$c->[1].$d->[0]\", op_$c->[0]  Op." . $oper_map{$vtype . $c->[3]} ." \"$d->[1]\" $cncons $t)";
        } elsif ($c->[0] =~ /^a[aI]$/) {
            push @cmeth, "($nn,toInstName \"$x$c->[1].$d->[0]\", op_$c->[0]  Op." . $oper_map{$vtype . "_" . $c->[3]} ." \"$d->[1]\" $cncons $t)";
        } else {
            push @meth, "($nn,toInstName \"$x$c->[1].$d->[0]\", \"$c->[0]\", \"prim_op_$c->[0].$c->[3]\", \"$d->[0]\")";
        }
    }
}

my $head = `cat data/PrimitiveOperators-in.hs`;
print "$head\n";
print "primitiveInsts = [\n   ", join("\n  ,",@inst), " ]\n\n";
print "constantMethods = [\n   ", join("\n  ,",@cmeth), " ]\n\n";
print "theMethods = [\n   ", join("\n  ,",@meth), " ]\n\n";
#push @names, "(dc_Unit, tc_Unit, undefined,\"void\",\"void\")\n";
#push @names, "(undefined, tc_World__, undefined,\"void\",\"void\")\n";
#push @names, "(\"Jhc.IO.World__\",\"void\",\"void\")";
print "allCTypes = [\n   ", join("  ,",@names), " ]\n\n";

print join("\n",map { $_->[1] } values %tcon) . "\n\n";
print join("\n",map { $_->[1] } values %tycon) . "\n\n";
print join("\n",map { $_->[1] } values %hsname) . "\n\n";
print join("\n",map { "{-# NOINLINE $_->[0] #-}" } values %hsname) . "\n\n";
print join("\n",map { $_->[1] } values %dcon) . "\n\n";
print join("\n",map { $_->[1] } values %rtype) . "\n\n";

print "\n\n";