#!/usr/bin/perl

die "$0 requires perl 5.0 or higher" unless $] >= 5.0;

$ending="dll"; # Set to "so" on Unix systems

foreach $file (@ARGV) {
    open(OUTC,">$file.c")   || die "Can't write to $file.c";
    open(OUTH,">$file.hs")  || die "Can't write to $file.hs";
    &processFile("$file.ps");
    &endModule("externs");
    close OUTC;
    close OUTH;
}
exit $errors;


#   %constructor $name :: $ty1 -> ... $tyn -> IOError [# $comment]
#

sub processFile {
    local($file) = @_;
    local(*IN);
    open(IN,"<$file") || &blurt("Couldn't open $file"); 
    while (<IN>) {
	s/\s+$//;
	next if /^$/;     # blank lines
	next if /^#/;     # comments
	if (/^\{%/) {
	    while (<IN>) {
		last if (/^\%\}/);
		print OUTC &expandMacros($_);
	    }

	} elsif (/^\{\{%/) {
	    while (<IN>) {
		last if (/^%\}\}/);
		print OUTH;
	    }

	} elsif (/^%asm\s+(.*)$/) {
	    $line = $1;
	    @lines = ();
	    while (<IN>) {
		push(@lines,$_);
		last if (/^\s*$/);
	    }
	    &processAsm($line,@lines);

	} elsif (/^%constructor\s+(\w*)\s*::\s*([^#]*)(\#(.*))?$/) {
	    &processConstructor($1,$2);

	} elsif (/^%type\s/) {
	    ($dummy, $haskell, $cdecl, $pk, $unpk) = split(/\s*:\s*/);

	    $cdecl{$haskell}  = &expandMacros($cdecl);
	    $unpack{$haskell} = &expandMacros($unpk);
	    $pack{$haskell}   = &expandMacros($pk);

	} elsif (/^%unpack\s/) {
	    ($dummy, $haskell, $cdecl) = split(/\s*:\s*/);
	    $unpk = "";
	    while (<IN>) {
		last if /^$/;
		$unpk = $unpk . $_;
	    }
	    chop($unpk);
	    $cdecl{$haskell}  = &expandMacros($cdecl);
	    $unpack{$haskell} = &expandMacros($unpk);

	} elsif (/^%pack\s/) {
	    ($dummy, $haskell) = split(/\s*:\s*/);
	    $pk = "";
	    while (<IN>) {
		last if /^$/;
		$pk = $pk . $_;
	    }
	    chop($pk);
	    $pack{$haskell} = &expandMacros($pk);

	} elsif (/^%error\s/) {
	    ($dummy, $haskell, $cdecl, $test, $pk) = split(/\s*:\s*/);

	    $cdecl{$haskell}  = &expandMacros($cdecl);
	    $test{$haskell}   = &expandMacros($test);
	    $pack{$haskell}   = &expandMacros($pk);

	} elsif (/^%struct\s/) {
	    ($dummy, $ty, $cdecl) = split(/\s*:\s*/);
	    $cdecl{$ty}     = &expandMacros($cdecl);
	    @fields=@fieldtys=();
	    while (<IN>) {
	        s/#.*//; # delete comments
		s/^\s+//;
		s/\s+$//;
		last if /^$/;
		($fieldty,$field) = split(/\s*:\s*/);
		push(@fieldtys,$fieldty);
		push(@fields,  $field);
	    }
	    &processStruct($ty,*fields,*fieldtys);

	} elsif (/^%include\s*(.*)$/) {
	    &processFile($1);

	} elsif (/^\s*#/) {
	    next;

	} else {
	    &blurt("Unrecognised input: $_");
	}
    }
    close(<IN>);
}

sub processStruct {
    local($ty,*fields,*fieldtys) = @_;
    local(@packfields,@unpackfields) = ();

    for $i (0..$#fields) {
	$fieldty = $fieldtys[$i];

	&blurt("Can't pack type $fieldty")   unless $pack{$fieldty};
	push(@packfields, &expand($pack{$fieldty}, "(\$0).$fields[$i]"));

	&blurt("Can't unpack type $fieldty") unless $unpack{$fieldty};
	push(@unpackfields,&expand($unpack{$fieldty}, "hugs_pop()", "(\$1).$fields[$i]"));
    }

    $pack{$ty}   = &mkTuple(@packfields);
    $unpack{$ty} = "hugs->eval(\$0);\n" . join(";\n",@unpackfields);

    print OUTH "type $ty = (", join(",", @fieldtys), ")\n";
}

# Define a new IOError constructor
sub processConstructor {
    local($name,$ty) = @_;
    local(@tys,$arity,$rty);
    local($line,@lines,$buildResult,$buildFail);
    @tys = split("\s*->\s*",$ty);
    $rty = pop(@tys);
    &blurt("%constructor $name must have result type IOError") unless $rty =~ /^\s*IOError\s*$/;
    &blurt("%constructor $name defined twice") if $constrTypes{$name};
    $constrTypes{$name} = $ty;
    $arity = @tys;
    push(@constrs,"XSname_$name = hugs->addPrimCfun(hugs->inventText(),$arity,0,NIL);");
    print OUTC <<"EOF";
Name XSname_$name;
EOF
    if ($arity == 0) {
	$ty = "IOError -> Bool";
    } else {
	$ty = "IOError -> Maybe (" . join(") (",@tys) . ")";
    }
    print OUTH <<"EOF";
primitive is$name "XStest_is$name" :: $ty
EOF

    if ($arity == 0) {
	$buildResult = "%return(1);";
	$buildFail   = "%return(0)";
    } elsif ($arity == 1) {
	$buildResult = "hugs_updapRoot(hugs->nameJust,hugs_pop());";
	$buildFail   = "%nothing()";
    } else {
	$buildResult = <<"EOF";
	Int i;
	Cell temp;
	temp = hugs->mkTuple($arity);
	for(i=0; i < $arity; ++i) {
	    temp = hugs_ap(temp,hugs_pop());
	}
	updapRoot(hugs->nameJust,temp)
EOF
	$buildFail   = "%nothing()";
    }

    $line = "XStest_is$name :: $ty";
    @lines = <<"EOF";
    hugs->eval(hugs_primArg(1));
    if (hugs_whnfHead==XSname_$name) {
	$buildResult;
    } else {
	$buildFail;
    }
EOF
    &processAsm($line,@lines);

}

sub processAsm {
    local($line,@lines) = @_;
    local($io,$maybe, $updateseen);
    local($name, $argtypestr) = split(/\s*::\s*/,$line,2);
    @argtypes = split(/\s*->\s*/, $argtypestr);

    # Fiddle with the result type:
    $rtypestr = pop(@argtypes);
    $rtypestr =~ s/[\(\)]//g;   # delete parentheses
    $rtypestr =~ s/\s+/ /g;     # normalise white space
    if ($rtypestr =~ /^IO\s+(.*)$/) {
	$io = 1;
	push(@argtypes,"Cell", "Cell");
	$rtypestr = $1;
    }
    if ($rtypestr =~ /^Maybe\s*(.*)$/) {
	$maybe = 1;
	$rtypestr = $1;
    }
    @rtypes = split(/\s*,\s*/,$rtypestr); # split result type

    push(@prims,$name);
    $arity = @argtypes;
    $arity{$name} = $arity;
    print OUTC "\nPROTO_PRIM($name);\n";
    print OUTC "primFun($name) {\n";
    foreach $line (@lines) {
	print OUTC "    ", &expandMacros($line);
    }
    print OUTC "    \{\n";
    print OUTC "    \}\n";
    &blurt("No %return seen") unless $updateseen;
    print OUTC "}\n";
}

# Expand any macros in line.
#
# Note: All "macros" are of the form %<name>(arg1,..argn);
# We use ";" to detect the end of the macro and "," to separate
# the arguments. 
# The only fly in the ointment is that sometimes you want the semicolon
# to be reinserted and sometimes you want it deleted.  
# HACK WARNING: In the latter case, you should write "%foo(...);%" - 
# and we'll delete the semicolon when we're all done.
#
# If you want to use "," for any other purpose within the line,
# you have to write "%comma" (which is expanded after all other
# processing completes).
# (Alternatively, you could do "#define COMMA ," in the C preprocessor.)
sub expandMacros {
    local ($line) = @_;
    while ($line =~ /%(\w+)\(([^;]*);/) {
	local($pre,$tag,$args,$post) = ($`,$1,$2,";$'");
	local (@rs,$r);
	chop $args; # Drop the last character (should be a ")")
	$args =~ s/\s//g;    # delete white space - should be irrelevant
	@rs = split(",", $args);

	if ($tag eq "getArg") {
	    &blurt("%getArg arity mismatch") if @rs < 1;
	    $i = shift(@rs);
	    $offset = @argtypes-$i;
	    $line = $pre . &coerceVal("hugs_primArg($offset)", $argtypes[$i], @rs) . $post;

	} elsif ($tag eq "unpack") {
	    &blurt("%coerce arity mismatch") if @rs != 3;
	    ($ty,$val,@rs) = @rs;
	    $line = $pre . &coerceVal($val, $ty, @rs) . $post;

	} elsif ($tag eq "pack") {
	    &blurt("%pack arity mismatch") if @rs != 2;
	    $ty = shift(@rs);
	    &blurt("Can't pack type $ty") unless $pack{$ty};
	    $line = $pre . &expand($pack{$ty}, @rs) . $post;

	} elsif ($tag eq "constructor") {
	    &blurt("%constructor arity mismatch") if @rs < 1;
	    $name = shift(@rs);
	    &blurt("unknown %constructor $name") unless $constrTypes{$name};
	    @cty = split("\s*->\s*",$constrTypes{$name});
	    pop(@cty);
	    &blurt("%constructor $name arity mismatch") unless $#rs == $#cty;
	    $expansion = "hugs_push(XSname_$name);";
	    foreach $i (0..$#rs) {
		$expansion .= " %pack($cty[$i],$rs[$i]); hugsRAP;"
	    }
	    $line = $pre . $expansion . $post;

	} elsif ($tag eq "declare") {
	    &blurt("%declare arity mismatch") if @rs != 2;
	    $line = $pre . &declareVar( @rs ) . $post;

	} elsif ($tag eq "return") {
	    $line = $pre . "%update($args); return" . $post;

	} elsif ($tag eq "errreturn") {
	    &blurt("%errreturn can only be used in IO functions") if !$io;
	    &blurt("%errreturn arity mismatch") if @rs < 2;
            local ($errty, $errval) = splice(@rs,0,2);
	    &blurt("Can't test error type $errty") unless $test{$errty};
	    local ($test) = &expand($test{$errty}, $errval);
	    $line = $pre . "if ($test) {%failWith($errty,$errval);} %return(".join(",",@rs).")" . $post;

	} elsif ($tag eq "update") {
	    $r = &mkResult(@rs);
	    $r .= " hugsJUST; hugsAP;" if $maybe;
	    $r .= " hugsSUCC; hugsAP;" if $io;
	    $line = $pre . &mkUpdate($r) . $post;

	} elsif ($tag eq "failWith") {
	    &blurt("%failWith doesn't match return type") if !$io;
	    &blurt("%failWith arity mismatch") if @rs < 1;
	    local($errty) = shift(@rs);
	    &blurt("Can't pack type $errty") unless $pack{$errty};
	    $r = &expand($pack{$errty},@rs);
	    $r .= " hugsFAIL; hugsAP;";
	    $line = $pre . &mkUpdate($r) . "; return" . $post;

	} elsif ($tag eq "fail") {
	    &blurt("%fail arity mismatch") if @rs != 0;
	    $line = $pre . "hugs_cantReduce()" . $post;

	} elsif ($tag eq "nothing") {
	    &blurt("%nothing arity mismatch")            if @rs != 0;
	    &blurt("%nothing doesn't match return type") if !$maybe;
	    $line = $pre . &mkUpdate(hugsNOTHING) . $post;

	} else {
	    &blurt("Unrecognised macro %$tag");
	    last;
	}
    }
    $line =~ s/%comma/,/g;
    $line =~ s/%colon/:/g;
    $line =~ s/;%//g;
    return $line;
}

# The result is just a bunch of result values - coerce them and build a tuple
sub mkResult {
    local(@rs) = @_;
    &blurt("Return arity mismatch")               if $#rs != $#rtypes;
    foreach $i (0..$#rs) {
	&blurt("Can't pack type $rtypes[$i]") unless $pack{$rtypes[$i]};
	$rs[$i] = &expand($pack{$rtypes[$i]}, $rs[$i]);
    }
    return &mkTuple(@rs);
}

sub mkTuple {
    local(@rs) = @_;
    local($size) = scalar @rs;

    if ($size == 0) {
	return "hugsUNIT;";
    } elsif ($size == 1) {
	return $rs[0];
    } else {
	local($i,$x);
	$x = "$rs[0] hugsTUPLE($size); hugsAP;";
	foreach $i (1..$#rs) {
	    $x .= " $rs[$i] hugsRAP;";
	}
	return $x;
    }
}

# add "updateRoot(...)" round argument performing any optimisations
# that spring to mind and returning state if need be.
sub mkUpdate {
    local($result) = @_;

    # For error catching purposes
    $updateseen = 1;

    # Special case: CAFs (fns of arity 0) push their result and abstract
    #  machine performs the update.
    # (Doing an update doesn't work!!)
    if ($arity == 0) {
        return $result;
    }

    # optimisation to avoid introducing indirection node
    if (substr($result,-8) eq "hugsRAP;") {
	return (substr($result,0,length($result)-8) . "hugsRUPDAPROOT;"); 
    } elsif (substr($result,-7) eq "hugsAP;") {
	return (substr($result,0,length($result)-7) . "hugsUPDAPROOT;"); 
    }

    # default action
    return $result . " hugsUPDATEROOT;";
}

# whine about errors in input file
sub blurt { warn(@_, " at line $..\n"); $errors++ }

# evaluate a Haskell argument from stack - storing specified vars.
sub coerceVal {
    local ($val, $type, @vars) = @_;
    &blurt("Can't unpack type $type") unless $unpack{$type};
    return &expand($unpack{$type},$val,@vars);
}    

# declare a variable to hold a variable of given Haskell type.
sub declareVar{
    local ($type, $var) = @_;
    &blurt("Can't declare var of type $type") unless $cdecl{$type};
    return &expand($cdecl{$type},$var);
}    

sub endModule {
    local ($module) = @_;

    print OUTC "
struct primitive primTable\[\] = {
";
    foreach $i (0..$#prims) {
	$name = $prims[$i];
	print OUTC "\t    {\"$name\", $arity{$name}, $name},\n";
    }
    @prims=@arities=();
    print OUTC "
\t    {0,0,0}
};
";

        print OUTC "
static Void control$module Args((Int));
static Void local control$module(what)
Int what; {
    switch (what) {
	case INSTALL : 
";
        foreach $constr (@constrs) {
	    print OUTC "\t\t$constr\n";
	}
	@constrs = ();

        print OUTC "
                break;
    }
}
static struct primInfo prims = { control$module, primTable, 0 };

/* After dynamically loading a module, Hugs looks up this symbol and
 * calls it with a \"virtual function table\" containing all necessary
 * parts of the Hugs API.  
 * (Much painful experimentation established that this was the most
 *  portable way for a DLL/shared object to access parts of Hugs.)
 *
 * This should be the only symbol exported from this module.
 */
DLLEXPORT(void) initModule(HugsAPI1 *);
DLLEXPORT(void) initModule(HugsAPI1 *hugsAPI) {
    hugs = hugsAPI;
    hugs->registerPrims(&prims);
    control$module(INSTALL);
}
";
        print OUTH "\nneedPrims_hugs 1\n";
}

# substitute arguments into a string
sub expand {
    local($s, @args) = @_;
    local($i);
    foreach $i (0..$#args) {
	$s =~ s/\$$i/$args[$i]/g;
    }
    $s;
}

# Strip outer parantheses from a string
sub stripParens {
    local($s) = @_;

    if (substr($s,0,1) eq "(" && substr($s,-1,1) eq ")" && $s ne "()") {
	$s = substr($s,1,-1);
    }

    return $s;
}
