#!/usr/bin/perl -w

# This script is an evil hack (TM). Please feel free to improve it
# or rewrite it (preferably in Haskell)

my %haskelltypes = ('char' => 'CChar',
		    'I32' => 'CInt',
		    'U32' => 'CUInt',
		    'bool' => 'CInt',
		    'void' => '()',
		    'IV' => 'CInt',
		    'NV' => 'CDouble',
		    'STRLEN' => 'CInt',
		    'int' => 'CInt');

sub mk_haskell_type {
  my ($ctype,$altsv)=@_;

  $ctype =~ s/const\s+//;

  my $ptrcount=0;

  while (substr($ctype,-1) eq '*'){
    $ctype = substr($ctype,0,-1);
    $ptrcount++;
  }

  my $htype='';

  if (exists $haskelltypes{$ctype}) {
    $htype = $haskelltypes{$ctype};
  } else {
    $htype = $ctype;
  }

  if (defined $altsv && $htype eq 'SV') {
    $htype = $altsv;
  }

  while($ptrcount > 0) {
    if ($htype =~ /\s/) {
      $htype = "Ptr ($htype)";
    } else {
      $htype = "Ptr $htype";
    }
    $ptrcount--;
  }

  return $htype;
}

sub split_decl {
  my ($decl)=@_;
  my ($type,$name) = $decl=~/^(.*)\s+(\S+)$/;
  return [$type,$name];
}

sub gen_protos {
  my ($source) = @_;

  return if $source =~ /^\s*$/;

  my ($ret,$name,$args,$extra) = ($source =~ /^\s*([\w\_\*]+)\s+([\w\_]+)\s*\(([^\)]*)\)\s*(?:\[([\w\,]+)\])?\s*$/);
  $args =~ s/\s+\*/\* /g;
  my @args = split /\s*,\s*/, $args;
  my @extra = defined $extra ? split ',', $extra : ('SV');
  print OUTCFILE "$ret do_$name";
  if (scalar @args==0) {
    print OUTCFILE "(pTHX) ";
  } else {
    print OUTCFILE "(pTHX_ $args) ";
  }
  print OUTCFILE "{ ";
  print OUTCFILE "return " if $ret ne 'void';
  print OUTCFILE "$name(".join(', ',map { &split_decl($_)->[1] } @args).")";
  print OUTCFILE " != 0" if $ret eq 'bool';
  print OUTCFILE "; }\n";

  foreach my $altsv (@extra) {

    my $hname = lcfirst($name);
    my $altsvlower = lc($altsv);
    $hname =~ s/^sv/$altsvlower/;
    $hname =~ s/sv_/${altsvlower}_/;

    print OUTHSFILE "foreign import ccall \"do_$name\" $hname :: ";
    print OUTHSFILE
      join(' -> ',
	   ("Ptr PerlInterpreter",
	    (map { &mk_haskell_type(&split_decl($_)->[0],$altsv) } @args),
	    "IO (".&mk_haskell_type($ret,$altsv).")"))."\n";
    print OUTHSFILE "\n";
  }
}

die "Usage: $0 <infile> <outcfile> <outhsfile>"
  unless scalar(@ARGV) == 3;

my ($infile,$outcfile,$outhsfile) = @ARGV;

open INFILE,"<$infile" or die "Couldn't open $infile for reading";
open OUTCFILE,">$outcfile" or die "Coultn't open $outcfile for writing";
open OUTHSFILE,">$outhsfile" or die "Coultn't open $outhsfile for writing";

my $insideperlop = 0;
my $insidedef = 0;

while(<INFILE>) {
  if ($insideperlop && /^\s*\}\s*$/) {
    $insideperlop = 0;
  } elsif ($insideperlop) {
    chomp;
    &gen_protos($_);
  } elsif (/^#perlop\s*\{\s*$/) {
    $insideperlop = 1;
  } elsif (/^#perlop(.*)$/) {
    &gen_protos($1);
  } elsif ($insidedef && /^#def\s*\}\s*$/) {
    $insidedef = 0;
  } elsif ($insidedef) {
    print OUTCFILE;
  } elsif (/^#def\s*\{\s*$/) {
    $insidedef = 1;
  } elsif (/^#def(.*)$/) {
    print OUTCFILE $1."\n";
  } elsif (/^#include/) {
    print OUTCFILE;
  } else {
    print OUTHSFILE;
  }
}

close INFILE;
close OUTCFILE;
close OUTHSFILE;