#!/usr/bin/perl

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

@includedirs = (".","..");
@files = ();
$outfile = "";
foreach $arg (@ARGV) {
    if ($arg =~ /^-I(.*)/) {
	push(@includedirs,$1); 
    } elsif ($arg =~ /^-o(.*)/) {
	$outfile = $1;
    } else {
	push(@files,$arg);
    }
}
if ($outfile eq "") {
    $outfile = $files[0];
    $outfile =~ s/.ss\$/.ps\$/g;
}

# print "Writing to \"$outfile\"\n";
open(OUTPS,">$outfile")  || die "Can't write to $file.ps";
foreach $file (@files) {
    &processFile("$file");
}
&mkConstFuns();
close OUTPS;

exit $errors;



# We recognise various special patterns:
#
#   %include $filename
#
#   %const $ty [$name =] $const [# $comment]
#
#   %fun              $fun :: $ty1 -> ... $tyn -> ($rty0,..$rtyn) [using $template]
#   %errfun $errlabel $fun :: $ty1 -> ... $tyn -> ($rty0,..$rtyn) [using $template]
#    ($template is of the form:
#     [$x =] $cfun($y1, ... $ym) [-> ($z1, ... $zn)]
#     where $x  is either "$err" or "$ri"
#           $yi is either "$x" or "&$x"
#           $zi is one of "$r0" ... "$rn"
#
#   %prim $name          :: $ty1 -> ... $tyn -> $rty
#   $body
#   <blank line>
#
#   %ptr : $ptrty : $ty
#     (defines "CObject" instance for "$ptrty" objects which point to "$ty"s)
#
#   %maybe : $newty : $oldty : $test : $null
#
#   %array          : $newty : $oldty : $cty [: $size]
#   %sentinel_array : $newty : $oldty : $cty : $sentinel : $test : [: $size]
#     if $size == "persistent", array is malloc'd when unpacked
#     if $size is omitted, array is alloca'd when unpacked
#     otherwise $size specified maximum length of array.
#
#   %synonym : $newty : $oldty [: noTypedef | nodecl]
#
#   %newtype : $newty : $oldty : $classList [: noTypedef | nodecl]
#
#   %mallocptr : $newty : $cdecl : $cleanup
#     ($cleanup should deallocate the object. Type: Void (*$cleanup)(Void *).)
#
#   %stableptr : $newty 
#
#   %var : $name : $ty [: noVarDecl]
#
# Anything else we just pass over unchanged

sub processFile {
    local($file) = @_;
    local(*IN);
    local($ty,$name,$comment,$argtys);
    local($foundit);
    foreach $dir (@includedirs) {
	# print "Trying $dir/$file\n";
	last if $foundit=open(IN,"<$dir/$file");
    }
    &blurt("Couldn't open $file") unless $foundit; 
    while (<IN>) {
	s/\s+$//;
	if (/^%include\s*(.*)$/) {
	    &processFile($1);
	} elsif (/^%const\s+(\w*)\s+(\w+)\s*(=\s*([^\s]*))?\s*(\#\s*(.*))?$/) {
	    if ($4 eq "") {
		&processConst($1,&mkHaskName($2),$2);
	    } else {
		&processConst($1,&mkHaskName($2),$4);
	    }
	} elsif (/^%fun\s+(\w+)\s*::\s*(.*)$/) {
	    ($ty, $template) = split(/\s*using\s*/,$2,2);
	    &processFun("",$1,$ty,$template,"");
	} elsif (/^%errfun\s+(\w+)\s+(\w+)\s*::\s*(.*)$/) {
	    ($ty, $template) = split(/using\s*/,$3,2);
	    &processFun($1,$2,$ty,$template,"");
	} elsif (/^%prim\s+(\w*)\s*::\s*(.*)$/) {
	    $body = "";
	    while (<IN>) {
		last if (/^$/);
		$body = $body . $_;
	    }
	    chop $body;
	    &processFun("",$1,$2,"",$body);

	} elsif (/^%ptr\s/) {
	    ($dummy, $ptrty, $ty) = split(/\s*:\s*/);
	    &processPtr($ptrty, $ty);

	} elsif (/^%synonym\s/) {
	    ($dummy, $newty, $oldty, $flags) = split(/\s*:\s*/);
	    &processSynonym($newty,$oldty,$flags);

	} elsif (/^%newtype\s/) {
	    ($dummy, $newty, $oldty, $classList, $flags) = split(/\s*:\s*/);
	    &processNewtype($newty,$oldty,$classList,$flags);

	} elsif (/^%mallocptr\s/) {
	    ($dummy, $newty, $cdecl, $cleanup) = split(/\s*:\s*/);
	    &processMallocPtr($newty,$cdecl,$cleanup);

	} elsif (/^%stableptr\s/) {
	    ($dummy, $newty) = split(/\s*:\s*/);
	    &processStablePtr($newty);

	} elsif (/^%array\s/) {
	    ($dummy, $type, $subtype, $ctype, $size) = split(/\s*:\s*/);
	    $size =~ s/\s*//g;
	    if ($size eq "persistent") {
		$decl  = "int \$0_size; $ctype\* \$0";
		$alloc = "\$1_size = ppindex; \$1 = ($ctype *) malloc(ppindex * sizeof($ctype)); if (!\$1) { %fail(); }";
	    } elsif ($size eq "") {
		$decl  = "int \$0_size; $ctype\* \$0";
		$alloc = "\$1_size = ppindex; \$1 = ($ctype *) alloca(ppindex * sizeof($ctype)); if (!\$1) { %fail(); }";
	    } else {
		$decl  = "$ctype \$0\[$size\]";
		$alloc = "if (ppindex > $size) { %fail(); }";
	    }
	    &processArray($type, $subtype, $decl, $alloc, "");

	} elsif (/^%sentinel_array\s/) {
	    ($dummy, $type, $subtype, $ctype, $sentinel, $test, $size) = split(/\s*:\s*/);
	    $size =~ s/\s*//g;	
	    $sentinel = &expand($sentinel,"\$1[ppindex]");
	    if ($size eq "persistent") {
  	        $decl  = "int \$0_size; $ctype\* \$0";
	        $alloc = "\$1_size = ppindex; \$1 = ($ctype *) malloc((ppindex+1) * sizeof($ctype)); if (!\$1) { %fail(); } $sentinel;";
	    } elsif ($size eq "") {
  	        $decl  = "int \$0_size; $ctype\* \$0";
	        $alloc = "\$1_size = ppindex; \$1 = ($ctype *) alloca((ppindex+1) * sizeof($ctype)); if (!\$1) { %fail(); } $sentinel;";
	    } else {
		$decl  = "$ctype \$0\[$size\]";
		$alloc = "if (ppindex+1 > $size) { %fail(); } $sentinel;";
	    }
	    &processArray($type, $subtype, $decl, $alloc, $test);

	} elsif (/^%maybe\s/) {
	    ($dummy, $type, $subtype, $test, $null) = split(/\s*:\s*/);
	    &processMaybe($type, $subtype, $test, $null);

	} elsif (/^%var\s/) {
	    ($dummy, $name, $type,$restrictions) = split(/\s*:\s*/);
	    &processVar($name, $type, $restrictions);

	} else {
	    print OUTPS $_, "\n";
	}
    }
    close(<IN>);
}

# Note: these quote functions have to come early in the file (or be
# predeclared) or Perl (and the poor Perl programmer) gets confused.

# Some random quote
sub Q {
    local($text) = shift;
    $text =~ tr/#//d;
    $text =~ s/\[\[/{/g;
    $text =~ s/\]\]/}/g;
    $text;
}

# Quote a piece of Haskell
sub H {
    local($text) = shift;
    $text =~ tr/#//d;
    $text =~ s/\[\[/{/g;
    $text =~ s/\]\]/}/g;
    "{{%\n" . $text . "%}}\n";
}

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

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

# Define a Haskell constant $name which is equal to a C constant $const
sub processConst {
    local($ty,$name,$const) = @_;
    local($consts) = $consts{$ty};
    $consts{$ty} = $consts = [] if !defined $consts;
    push(@$consts,$const);

    print OUTPS H<<"EOF";
#$name :: $ty
#$name = consts_$ty $#$consts
EOF
}

# Note that we assume that the same type name is being used for
# both Haskell and C.
sub mkConstFuns {
    while (($ty, $consts) = each %consts) {
	$consts = join(",\n\t", @$consts);
	print OUTPS &Q(<<"EOF");
#
#%asm XSconsts_$ty :: Int -> $ty
#    static $ty consts[] = [[\n\t$consts\n\t]];
#    int i;
#    %getArg(0,i);
#    %return(consts[i]);
#
EOF

    print OUTPS &H("primitive consts_$ty \"XSconsts_$ty\" :: Int -> $ty\n");
    }
}

# Generate a Haskell function $name :: $ty which either calls a 
# C function according to a template or executes statement $stat.
sub processFun {
    local($errty,$name,$ty,$template,$stat) = @_;
    local($pre,$post,$errvar);

    @argtys = split(/\s*->\s*/,$ty);
    $rty = pop(@argtys);
    if ($rty =~ /^IO\s+(.*)$/) {
	$rty = $1;
    }
    $rty =~ s/\(//g;    # Strip parens out of result type:
    $rty =~ s/\)//g;
    @rtys = split(",",$rty);

    $pre = "";

    print OUTPS &Q(<<"EOF");
#%asm XS_$name :: $ty
#{
EOF
    foreach $i (0..$#argtys) {
	print OUTPS "\t%declare($argtys[$i],pparg$i);\n";
    }
    $args = "";
    foreach $i (0..$#argtys) {
	print OUTPS "\t%getArg($i,pparg$i);\n";
	$args = $args . "\$$i,";
    }
    chop($args); # delete the extra comma

    if ($stat eq "") {
	($call,$result) = split("->",$template);
	$result =~ s/\(//g;    # Strip out parens
	$result =~ s/\)//g;
	if ($call eq "") {
	    $call = "$name($args)";
	    if ($rty ne "") {
		$call = "\$r0 = $call";
	    } elsif ($errty ne "") {
		$call = "\$err = $call";
	    }
	}
	# Figure out which result variables we have to declare/return
	# You must use contiguous result variables starting from 1
	#   Cool:   ($r0,$r1,$r2)
	#   Cool:   ($r1,$r0,$r2)
	#   Uncool: ($r1,$r0,$r3)   -- omits $r2
	#   Uncool: ($r1,$r2,$r3)   -- disnae start at $r0
	# Don't use any vars above $r9 - the engines cannae take it.
	@rets = ();
	for( $i=0; $i <= $#rtys; $i++) {
	    last if !($call =~ /\$r$i/);
	    $call   =~ s/\$r$i/ppret$i/g;
	    $result =~ s/\$r$i/ppret$i/g;
	    $pre   .= "\t%declare($rtys[$i],ppret$i);\n";	
	    push(@rets,"ppret$i");
	}

	# Figure out what to return, whether to perform an error test, whether to declare errvar.
	$result = join(",", @rets) if $result eq "";
	&blurt("\$err used in result") if $result =~ /\$err/;
	if ($call =~ /\$err/) {
	    &blurt("\$err should only be used with %errfun") if $errty eq "";
	    $call  =~ s/\$err/pperr/g;
	    $pre  .= "\t%declare($errty,pperr);\n";	
	    $post  = "%errreturn($errty,pperr";
	    $post .= ",$result" if $result ne "";
	    $post .= ");";
	} elsif ($errty eq "") {
	    $post  = "%return($result);";
	} else {
	    # assumes ppret0 exists and (hence) that $result is non-empty
	    $post  = "%errreturn($errty,ppret0,$result);";
	}
	$stat = "$pre\t$call;\n\t$post\n";
    } else {
	$stat = "$stat\n";
    }

    foreach $i (0..$#argtys) {    # "$i" is shorthand for "ppargi".
	$stat =~ s/\$$i/pparg$i/g;
    }
    print OUTPS "{\n$stat}}\n\n";

    $pname = &mkHaskName($name);
    print OUTPS &H("primitive $pname \"XS_$name\" :: $ty\n");
}

# Haskell variables have to start with a lowercase letter - this
# does the business.
sub mkHaskName {
    local($name) = @_;
    substr($name,0,1) =~ tr/A-Z/a-z/;
    $name;
}

# It'd be cleaner to define a type constructor "Ptr a" and a class
# "CObject a" having essentially the same methods as the Pointer class.
# Sadly, this won't work if $ty is a type synonym - as it often is using
# the current translation for %struct.
#
# In consequence (and not having multiparameter type classes to compensate)
# we don't have overloaded "get" and "set" methods.
# 
# We don't put "sizeof" in the type class because it's almost impossible
# to use an overloaded version. (Try defining a generic version of alloc!)
#
sub processPtr {
    local($ptrty,$ty) = @_;
    
    print OUTPS &Q(<<"EOF");
#{{%
#type $ptrty = Ptr in
#  to$ptrty   :: Ptr -> $ptrty,
#  from$ptrty :: $ptrty -> Ptr
#
#to$ptrty   x = x 
#from$ptrty x = x
#
#instance Pointer $ptrty where
#  toPtr     = from$ptrty
#  fromPtr   = to$ptrty
#  alloc     = malloc sizeof$ptrty
#  plus p x  = fromPtr (plusPtr (toPtr p) (x * sizeof$ptrty))
#  minus p q = (toPtr p `minusPtr` toPtr q) `div` sizeof$ptrty
#
#primitive get$ptrty        "XS_get_$ptrty"    :: $ptrty -> IO $ty
#primitive set$ptrty        "XS_set_$ptrty"    :: $ptrty -> $ty -> IO ()
#%}}
#
#%type : $ptrty	: $ptrty \$0 : %pack(Ptr,\$0);% : %unpack(Ptr,\$0,\$1);%
#
#%asm XS_get_$ptrty :: $ptrty -> IO $ty
#$ptrty p;
#%getArg(0,p);
#%return(*p);
#
#%asm XS_set_$ptrty :: $ptrty -> $ty -> IO ()
#$ty* p;
#%getArg(0,p);
#%getArg(1,*p);
#%return();
#
#
EOF
    &processConst("Int","sizeof$ptrty","sizeof($ty)");
}

# We coerce Haskell lists to C arrays in two stages:
# 1) We evaluate the spine of the list onto the stack.
# 2) We allocate the array and fill it in off the stack.

# When packing the array, we keep the resulting list on the stack
# as a half-hearted attempt to pacify the garbage collector.
#
# Rather than use push and pop, we keep the accumulated list at
# offset -1 on the stack and use offset 0 as a workspace.
# The minor reason is to reduce the calls to chkStack;
# the major reason is that "push(foo(pop()))" doesn't do what you'd
# expect it to.

sub processArray {
    local($type, $subtype, $decl, $alloc, $test) = @_;

    print OUTPS &Q(<<"EOF");
#%unpack : $type : $decl
#	[[  int ppindex; 
#	    hugs->eval(\$0);
#	    for (ppindex = 0; hugs_whnfHead == hugs->nameCons; ++ppindex) [[
#		Cell ppHead = hugs_pop(); 
#		Cell ppTail = hugs_pop(); 
#		hugs_push(ppHead);
#	        hugs->eval(ppTail);
#	    ]]
#           $alloc
#	    while (--ppindex >= 0) [[
#               %unpack($subtype,hugs_pop(),\$1[ppindex]);
#	    ]]
#	]]
#
EOF

    # Two versions of the packing code:
    # 1) We know the size of the array.
    # 2) The array contains a sentinel value.
    if ($test eq "") {
        print OUTPS &Q(<<"EOF");
#{%
#static Void XSpack_$type(ppArray, ppSize)
#$subtype *ppArray;
#Int       ppSize;
#[[
#    hugsNIL;
#    while (--ppSize >= 0) [[
#        %pack($subtype,ppArray[ppSize]);
#        hugsCONS;
#        hugsAP;
#        hugsAP;
#    ]]
#]]
#%}
#%pack : $type 
#XSpack_$type(\$0,\$0_size);
#
EOF
    } else {
	$test = &expand($test,"ppArray[ppSize]");
        print OUTPS &Q(<<"EOF");
#{%
#static Void XSpack_$type(ppArray)
#$subtype *ppArray;
#[[
#    int ppSize;
#    for (ppSize = 0; !($test); ppSize++) {}
#    hugsNIL;
#    while (--ppSize >= 0) [[
#        %pack($subtype,ppArray[ppSize]);;
#        hugsCONS;
#        hugsAP;
#        hugsAP;
#    ]]
#]]
#%}
#%pack : $type 
#XSpack_$type(\$0);
#
EOF
    }
}

# Build coercions for Maybe types
sub processMaybe {
    local($type,$subtype,$test,$null) = @_;

    print OUTPS &Q(<<"EOF");
#%unpack : $type : %declare($subtype,\$0);%
# hugs->eval(\$0); 
# if (hugs_whnfHead == hugs->nameJust) { 
#     %unpack($subtype,hugs_pop(),\$1); 
# } else {
#     \$1 = $null;
# }
#
#%pack : $type
#  if (\$0) { %pack($subtype,\$0); hugsJUST; hugsAP; } else { hugsNOTHING; }
#
#{%
#typedef $subtype $type;
#%}
#{{%
#type $type = Maybe $subtype
#%}}
EOF
}

sub processSynonym {
    local($newty, $oldty, $flags) = @_;
    
    print OUTPS &Q(<<"EOF");
#%type : $newty : %declare($oldty,\$0);% : %pack($oldty,\$0);% : %unpack($oldty,\$0,\$1);%
EOF

    $flags =~ tr/A-Z/a-z/;
    print OUTPS &Q(<<"EOF") if $flags !~ /notypedef/;
#{%
#typedef $oldty $newty;
#%}
EOF

    print OUTPS &Q(<<"EOF") if $flags !~ /nodecl/;
#{{%
#type $newty = $oldty
#%}}
EOF

}

sub processNewtype {
    local($newty, $oldty, $classList, $flags) = @_;
    
    print OUTPS &Q(<<"EOF");
#%type : $newty : %declare($oldty,\$0);% : %pack($oldty,\$0);% : %unpack($oldty,\$0,\$1);%
EOF

    $flags =~ tr/A-Z/a-z/;
    print OUTPS &Q(<<"EOF") if $flags !~ /notypedef/;
#{%
#typedef $oldty $newty;
#%}
EOF

    print OUTPS &Q(<<"EOF") if $flags !~ /nodecl/;
#{{%
#newtype $newty = $newty $oldty deriving $classList
#%}}
EOF

}

sub processMallocPtr {
    local($newty, $cdecl, $cleanup) = @_;
    
    print OUTPS &Q(<<"EOF");
#{{%
#type $newty = () in rtsDummy -- completely inaccurate (but it doesn't matter)
#%}}
#%type : $newty : $cdecl : hugs_push(hugs->mkMallocPtr(\$0,$cleanup)); : hugs->eval(\$0); \$1=hugs->derefMallocPtr(hugs_whnfHead)
EOF
}

sub processStablePtr {
    local($newty) = @_;
    
    print OUTPS &Q(<<"EOF");
#%type : $newty : Int \$0 : hugsStablePtr(\$0); : \$1=hugs->mkStablePtr(\$0)
EOF
}

sub processVar {
    local ($name,$ty,$flags) = @_;

    $flags =~ tr/A-Z/a-z/;
    print OUTPS &Q(<<"EOF") if $flags ne "novardecl";
#{%
#$ty $name;
#%}
EOF

    print OUTPS &Q(<<"EOF");
#{{%
#primitive get_$name "XSget_$name" :: IO $ty
#primitive set_$name "XSset_$name" :: $ty -> IO ()
#%}}
#
#%asm XSget_$name :: IO $ty
#{
#    %return($name);
#}
#
#%asm XSset_$name :: $ty -> IO ()
#{
#    %getArg(0,$name);
#    %return();
#}
#
EOF
}
