package Call::Haskell::FFIGenerator;
use warnings;
use strict;
use v5.16;
use Data::Dumper;
use Cwd;
use Digest::MD5;

use version; our $VERSION = version->declare('v0.2.0');

use Exporter 'import';

@Call::Haskell::FFIGenerator::EXPORT = qw(
  create_hs_ffi_generator
);

# This module generates all the glue code needed for calling Haskell from Perl.
# What we should do is test if the original module has changed via a checksum
our $VV=0;
sub create_hs_ffi_generator {
 ( my $module_name, my $function_names, my $inc, my $CLEAN, my $VV, my $perl_types ) = @_;
 $Call::Haskell::FFIGenerator::VV=$VV;
 
 my $wd = cwd();
 my $Call_Haskell_path=$INC{"Call/Haskell/FFIGenerator.pm"};
 my $hs_FFIGenerator_dir=$Call_Haskell_path;

 $hs_FFIGenerator_dir=~s/Call.Haskell.FFIGenerator.pm$//;
 if ($hs_FFIGenerator_dir=~/^\.\./) {
     $hs_FFIGenerator_dir='../'.$hs_FFIGenerator_dir;
 }
 if ( not -e '_Call_Haskell' ) {
  mkdir '_Call_Haskell';
 }
 chdir '_Call_Haskell';
 mkdir 'FFIGenerator';
 system("cp $hs_FFIGenerator_dir/FFIGenerator/*.hs FFIGenerator");
 my $generate = 0;
 if ( $CLEAN == 1 ) {
#  say "CLEANING generated sources" if $VV;
#  unlink $module_name . '_ffi_wrapper_gen.hs';
#  unlink $module_name . "FFIWrapper.hs";
#  unlink $module_name . "CWrapper.c";
#  unlink $module_name . "CWrapper.h";    
  $generate = 1;
 } else {
#  say "Computing MD5 for $wd/$inc/$module_name.hs";
  my $filename = "$wd/$inc/$module_name.hs";
  open( my $fh, '<', $filename ) or die "Can't open '$filename': $!";
  binmode($fh);
  my $md5 = Digest::MD5->new;
  while (<$fh>) {
   $md5->add($_);
  }
  close($fh);
  my $checksum = $md5->hexdigest;
  if ( -e "$module_name.md5" ) {
   open( my $md5fh, '<', "$module_name.md5" );
   my $ref_checksum = <$md5fh>;
   close $md5fh;   
   say "MD5:", $checksum eq $ref_checksum if $VV;
   if ( $checksum ne $ref_checksum ) {
    unlink "$module_name.md5";    
    $generate = 1;
   } else {       
    $generate = 0;
   }
  } else {
      say "no MD5 checksum for $module_name.md5" if $VV;
      
   $generate = 1;
  }
  if ( not -e "$module_name.md5" ) {
   $generate = 1;
   
   open( my $md5fh, '>', "$module_name.md5" );
   print $md5fh $checksum;
   close $md5fh;
  }
 }
 if (
  not( -e $module_name . '_ffi_wrapper_gen.hs'
   and -e $module_name . "FFIWrapper.hs"
   and -e $module_name . "CWrapper.c"
   and -e $module_name . "CWrapper.h"
   and -e $module_name . "_Inline_C.c" )
   )
 {

  $generate = 1;
 }
my $c_code='';
 if ( $generate == 1 ) {

  my $hs_module_dir = $inc;

  open my $GEN, '>', "${module_name}_ffi_wrapper_gen.hs";
  say $GEN "-- Code generated by $0 on " . scalar localtime;
  while ( my $line = <DATA> ) {
   if ( $line =~ /_MODULE_NAME_/ ) {
    $line =~ s/_MODULE_NAME_/$module_name/;
   }
   if ( $line =~ /_FUNC_/ ) {
    my $nlines = '';
    for my $function_name ( @{$function_names} ) {
     my $nline = $line;
     $nline =~ s/_FUNC_/$function_name/g;
     $nlines .= $nline;
    }
    $nlines =~ s/\,$//;
    $line = $nlines;
   }
   print $GEN $line;
  }
  close DATA;
  close $GEN;
 my $Call_Haskell_path=$INC{"Call/Haskell/FFIGenerator.pm"};
 my $hs_FFIGenerator_dir=$Call_Haskell_path;

 $hs_FFIGenerator_dir=~s/Call.Haskell.FFIGenerator.pm$//;

 #if ($hs_FFIGenerator_dir=~/^\./) {die "\nThe path to the Call::Haskell module _must_ be absolute, please redefine your PERL5LIB\n\n"; }
 $hs_FFIGenerator_dir='.'; 
 say  "FFIGenerator path:",$hs_FFIGenerator_dir if $VV;   
   my @hs_f_types = 
    `runhaskell -i$wd/$hs_module_dir -i$hs_FFIGenerator_dir ${module_name}_ffi_wrapper_gen.hs`;
   $c_code = create_C_wrapper( \@hs_f_types, $module_name );
 
  open my $INL_C_CODE, '>', $module_name . '_Inline_C.c';
  print $INL_C_CODE $c_code;
  close $INL_C_CODE;
  my @decomp_hs_types = map { decomposeHSType($_) } @hs_f_types;
#  say Dumper(@hs_f_types);
#  die Dumper(@decomp_hs_types);
  mkdir "$wd/_Call_Haskell/CallHaskellWrappers";
  for my $ft (@decomp_hs_types) {
   (my $fn, my $arg_types, my $ret_type)=@{$ft};
   if(isSimpleSig(@{$arg_types}, $ret_type)==0) {   
      if (not -e "$wd/_Call_Haskell/CallHaskellWrappers/$fn.pm")  {
       # create the sub       
       my $code = <<"ENDWC";
package CallHaskellWrappers::$fn;
use Exporter qw( import );
\@CallHaskellWrappers::${fn}::EXPORT = qw( $fn );

ENDWC
       my $hs_argtup_type = (scalar @{$arg_types} > 1) ?  '('.join(',',@{$arg_types}).')' : $arg_types->[0];
       
            $Data::Dumper::Indent=0;  
           $Data::Dumper::Terse=1;
        
        my $hs_type_str=Dumper($hs_argtup_type);
    if ($perl_types eq '') {             
        $code .= <<"ENDWH";
use Call::Haskell::ReadShow qw( showH readH );
require Call::Haskell; 
sub $fn {
    my \$hs_type=$hs_type_str;
    my \$in_str = Call::Haskell::ReadShow::showH(\@_,\$hs_type);
    my \$out_str=Call::Haskell::${fn}_ser(\$in_str);
    my \$res = Call::Haskell::ReadShow::readH(\$out_str);
    return \$res;
}

ENDWH
        
       } else {
my $use_perl_types = "$perl_types" eq '1' ? '' : "use $perl_types;";
    
       $code .= <<"ENDWTP";
use Call::Haskell::ReadShow qw( showH readH );       
use Types;
$use_perl_types
require Call::Haskell; 
sub $fn {
    my \$hs_type=$hs_type_str;
#    my \$in_str = '';
    my \@in_arg_strs=();
    for my \$arg (\@_) {
        if (ref(\$arg) eq 'Types') {    
            push \@in_arg_strs, Types::show(\$arg);
        } else {
           push \@in_arg_strs,  Call::Haskell::ReadShow::showH(\$arg,\$hs_type);
        }
    }
    my \$in_str = (\@_>1) ? '('.join(', ',\@in_arg_strs).')' : \$in_arg_strs[0];     
    my \$out_str=Call::Haskell::${fn}_ser(\$in_str);    
    my \$res = eval(\$out_str);
    return \$res;
}

ENDWTP

$code .= "1;\n";
       }
open my $SUB,'>',"$wd/_Call_Haskell/CallHaskellWrappers/$fn.pm";
print $SUB $code;
close $SUB;
      }
   }
    }   
 }
 else {
  say "NO GENERATION NECESSARY!" if $VV;
  open my $INL_C_CODE, '<', $module_name . '_Inline_C.c';
  while ( my $line = <$INL_C_CODE> ) {
   $c_code .= $line;
  }
  close $INL_C_CODE;
 }
 
 return ( $c_code, $generate );
}

my %SimpleTypes =
  map { ( $_ => 1, "IO $_" => 1 ) }
  qw( Int Integer Float Double String [Char] );

sub HstoP_types {
 ( my $hs_t, my $is_retval ) = @_;
 my $p_t = 'NONE';
 if ( $hs_t eq 'Int' ) {
  $p_t = 'long';
 }
 elsif ( $hs_t eq 'Double' ) {
  $p_t = 'double';

 }
 elsif ( $hs_t eq '[Char]' or $hs_t eq 'String' ) {
  if ($is_retval) {
   $p_t = 'SV*'
     ; # SvPV(sv_name, PL_na)  char* n_c_str = newSVpvf("STR: <%s %s> OK\n", c_str,hs_str);
  }
  else {
   $p_t = 'char*';
  }
 }
 else {

  # This type needs to be serialised, so it's a string
  # This is not correct on a per-arg basis, but we should not come here
  if ($is_retval) {
   $p_t = 'SV*'
     ; # SvPV(sv_name, PL_na)  char* n_c_str = newSVpvf("STR: <%s %s> OK\n", c_str,hs_str);
  }
  else {
   $p_t = 'char*';
  }
 }
 return $p_t;
}
# So with the new type datastructure this will work if the type is a string and it exists. 
# So that's fine in a very Perl-ish way 
sub isSimpleSig {
 ( my @hs_f_types ) = @_;
 my $test = 1;
 map { $test = $test && ( exists $SimpleTypes{$_} ? 1 : 0 ) }
   @hs_f_types  ;#( @{$argtypes}, $ret_type );
# say "isSimpleSig <$test>";
 return $test;
}

sub decomposeHSTypeOLD {
 ( my $hs_f_type ) = @_;
# say "decomposeHSType:",$hs_f_type;
 chomp $hs_f_type;
 ( my $f, my $args ) = split( /\s+::\s+/, $hs_f_type );
 my @argtypes = split( /\s+->\s+/, $args );
 my $ret_type = pop @argtypes;
 my $res= [ $f, \@argtypes, $ret_type ];
# say Dumper($res);
 return $res;
}

sub decomposeHSType {
 ( my $hs_f_type ) = @_;
# say "decomposeHSType:",Dumper($hs_f_type);
 chomp $hs_f_type;
 ( my $f, my $args ) = split( /\s+::\s+/, $hs_f_type );
# say "decomposeHSType:",$args;
 my $argtypes = eval($args);
 my $ret_type = pop @{$argtypes};
 my $res= [ $f, $argtypes, $ret_type ];
# say Dumper($res);die;
 return $res;
}

sub create_C_wrapper {
 ( my $hs_f_types, my $module_name ) = @_;
 my $inc    = '#include "' . $module_name . 'CWrapper.h"';
 my $date   = scalar localtime;
 my $c_code = "// Code generated by $0 on $date
$inc
int hs_begin(int n) {
    hs_${module_name}_init();
    return n;
}

int hs_end(int n) {
    hs_${module_name}_end();
    return n;
}
";
 my $ws = '    ';
 for my $hs_f_type ( @{$hs_f_types} ) {
  ( my $f, my $argtypes, my $res_t ) = @{&decomposeHSType($hs_f_type)};
  
#  say "TYPE: $hs_f_type";
#  say "DECTYPE:", Dumper($argtypes);
#  say $f;
  my @fdef_lines = do {

   if ( isSimpleSig(@{$argtypes}, $res_t) == 1 ) {
    say "SIMPLE!" if $VV;
    my $i = 0;
    (
     '',
     HstoP_types( $res_t, 1 ) . " $f("
       . join( ',', map { HstoP_types( $_, 0 ) . ' x' . ++$i } @{$argtypes} )
       . ') {',

     #            $ws.'printf("BEFORE FFI CALL\n");',
     $ws
       . HstoP_types( $res_t, 0 )
       . " res = ${f}_ffi_c("
       . join( ', ', map { "x$_" } ( 1 .. $i ) ) . ');',

     #            $ws.'printf("AFTER FFI CALL\n");',
     $ws 
       . HstoP_types( $res_t, 0 ) 
       . ' nres = '
       . (
      ( $res_t eq '[Char]' or $res_t eq 'String' ) ? 'newSVpv(res,0);' : 'res;'
       ),

     $ws . 'return nres;',
     '}',
     ''
    );
   }
   else {
    say "SERIALISE!" if $VV;
    (
     '',
     "SV* ${f}_ser(char* sstr) {",
     $ws . "char* res = ${f}_ffi_c(sstr);",
     $ws . 'SV* nres = newSVpv(res,0);',
     $ws . 'return nres;',
     '}', ''
    );
   }
  };

  my $fdef = join( "\n", @fdef_lines );

  #    print $fdef;
  $c_code .= $fdef;
 }
 return $c_code;
} # END of create_C_wrapper()

sub AUTOLOAD {
    our $AUTOLOAD;
        my $t=$AUTOLOAD;
        $t=~s/^.+:://;
        $t eq 'True' && do{$t=1};
        $t eq 'False' && do{$t=1};
        $t eq 'Nothing' && do{$t=undef};
    if (not @_) {
        return $t;
    } else {
            return {TypeName=>$t,TypeArgs=>[@_] };
    }
}

1;

# _FUNC_ gets populated for every function with magic commas

__DATA__
module Main where
import Data.Typeable ( typeOf )
-- import Data.List ( intercalate )
import FFIGenerator.TypeToPerl (  typeToPerl ) 
import FFIGenerator.GetTypes ( getFFITypes, hasSimpleSig, getTypes )
import FFIGenerator.GenerateCode ( createHaskellWrapper, createCWrapper, createCWrapperHeader )

import _MODULE_NAME_ 
-- ( 
--         _FUNC_,
--         )

module_name = "_MODULE_NAME_"
func_list =[
    ("_FUNC_", getFFITypes _FUNC_ , hasSimpleSig _FUNC_ , getTypes _FUNC_ ),
  ]

-- So this generated module provides module_name and func_list 
-- To do so, it requires getFFITypes and hasSimpleSig from FFIGenerator.GetTypes
-- The functions that generate the code can go in FFIGenerator.GenerateCode
 
main = do
    createHaskellWrapper module_name func_list
    createCWrapper module_name func_list
    createCWrapperHeader module_name func_list
    putStrLn $ "_FUNC_ :: "++(typeToPerl (show(typeOf _FUNC_)))
--    mapM (\(f,ffit,fs,ft) -> putStrLn (f++" :: "++ (intercalate " -> " ft))) func_list
