module FFIGenerator.GenerateCode ( createHaskellWrapper, createCWrapper, createCWrapperHeader )
where    

createHaskellWrapper module_name func_list = 
  let
    hs_wrapper_fp =  module_name++"FFIWrapper.hs"
    hs_wrapper_code = unlines [ffi_header, ffi_export_lines, ffi_wrapper_lines]
    gen_comment = "-- Code generated by "++module_name++"_ffi_wrapper_gen"
    func_list_str = joinWith (map (\(f,ft,fs,fht)->f) func_list) ", "
    ffi_header =unlines [
      gen_comment
      ,"{-# LANGUAGE ForeignFunctionInterface #-}"
      ,""
      ,"module "++module_name++"FFIWrapper where"
      ,""
      ,"import Foreign.C.Types"
      ,"import Foreign.C.String"
      , maybe_serialise func_list
      ,"import Data.Map"
      ,"import "++module_name -- ++" ( "++func_list_str++" )"
      ,""
      ]
    ffi_export_lines = unlines $ map gen_ffi_export func_list
    ffi_wrapper_lines = unlines $ map gen_ffi_wrapper func_list
  in 
    writeFile hs_wrapper_fp hs_wrapper_code
    
-- We also need to generate the C wrappers, that is a lot easier though
createCWrapper module_name func_list = 
  let
    c_wrapper_fp = module_name++"CWrapper.c"
    c_wrapper_code = c_ffi_header++(snd (ffi_c_h_lines func_list))
    ffi_module_name = module_name++"FFIWrapper"
    gen_comment = "// Code generated by "++module_name++"_ffi_wrapper_gen"   
    c_ffi_header = unlines [
      gen_comment
      ,"#include <HsFFI.h>"
      ,"#include \""++ffi_module_name++"_stub.h\""
      ,"extern void __stginit_"++ffi_module_name++"(void);"
      ,"#include <stdio.h>"
      ,""
      ,"void hs_"++module_name++"_init(void){"
      ,"    hs_init(0,0);"
      ,"    hs_add_root(__stginit_"++ffi_module_name++");"
      ,"}"
      ,""
      ,"void hs_"++module_name++"_end(void){"
      ,"        hs_exit();"
      ,"}"
      ,""
      ]    
  in
    writeFile c_wrapper_fp c_wrapper_code

createCWrapperHeader module_name func_list = 
  let
    c_wrapper_h_fp = module_name++"CWrapper.h"  
    gen_comment = "// Code generated by "++module_name++"_ffi_wrapper_gen"    
    c_h_ffi_decls = unlines [
       ""
      ,"void hs_"++module_name++"_init(void);"
      ,""
      ,"void hs_"++module_name++"_end(void);"
      ,""
      ]    
    c_wrapper_h_code = unlines [
        gen_comment,
        "#ifndef __"++module_name++"CWrapper__",
        "#define __"++module_name++"CWrapper__", 
        c_h_ffi_decls, 
        fst (ffi_c_h_lines func_list),
        "#endif"
        ] 
    
  in    
    writeFile c_wrapper_h_fp c_wrapper_h_code
    

ffi_arg_conversion (x,t)
    | t == "CLong" = "    let "++x++"' = fromIntegral "++x
    | t == "CInt" = "    let "++x++"' = fromIntegral "++x
    | t == "CDouble" = "    let "++x++"' = realToFrac "++x
    | t == "CString" = "    "++x++"'  <- peekCString "++x
    | otherwise = error $ "Type "++t++" not supported"
    

ffi_res_conversion (x,t)
    | t == "IO CLong" = "    let "++x++"' = fromIntegral "++x
    | t == "IO CInt" = "    let "++x++"' = fromIntegral "++x
    | t == "IO CDouble" = "    let "++x++"' = realToFrac "++x
    | t == "IO CString" = "    "++x++"'  <- newCString "++x
    | otherwise = error $ "Type "++t++" not supported"    

maybe_serialise func_list
  | foldl (&&) True (map (\(f,ft,fs,fht) ->  fs) func_list) = ""
  | otherwise = "import FFIGenerator.ShowToPerl"
  
gen_ffi_export (f,ft, fs,fht)
  | fs = let ffi_types = joinWith ft "->" in "foreign export ccall "++f++"_ffi  :: "++ffi_types 
  | otherwise = "foreign export ccall "++f++"_ffi :: CString -> IO CString"

gen_ffi_wrapper (f,ft,fs,fht)  
  | fs = 
    let
      ffi_types = ft 
      ffi_arg_types = init ffi_types
      ffi_res_type = last ffi_types
      args = map (\i -> "x"++(show i)) [1 .. length ffi_arg_types]
      args' = map (\i -> "x"++(show i)++"'") [1 .. length ffi_arg_types]
      ffi_sig = joinWith ffi_types "->"
      ffi_sig_line = f++"_ffi  :: "++ffi_sig
      ffi_fst_line = f++"_ffi  "++(unwords args)++" = do" 
      arg_conversion_lines = map ffi_arg_conversion (zip args ffi_arg_types)
      fcall_line = "    let res = "++f ++" "++(unwords args')
      res_conversion_line = (ffi_res_conversion ("res",ffi_res_type))
      ret_line = "    return res'"
      debug_line = "" -- "    putStrLn str "
    in    
      unlines $ [ffi_sig_line, ffi_fst_line]++ arg_conversion_lines ++[debug_line,fcall_line,debug_line,res_conversion_line,debug_line,ret_line]
  | otherwise = gen_readshow_wrapper f fht 
    -- let
      -- ffi_sig_line = f++"_ffi  :: CString -> IO CString" 
    -- in      
      -- unlines $ [ffi_sig_line, f++"_ffi = export . returnId2 $ "++f]
  

--  So, if the type is not "simple", the FFI type becomes CString -> IO CString and the function becomes:
gen_readshow_wrapper f ft = 
  let
      ffi_types = snd ft 
      ffi_arg_types = init ffi_types
      ffi_res_type = last ffi_types
      args = map (\i -> "x"++(show i)) [1 .. length ffi_arg_types]  
      ftype_tup 
        | length ffi_arg_types > 1 = "("++(joinWith (map show ffi_arg_types) ",")++")"
        | otherwise = show $ head ffi_arg_types
  in         
     unlines [
         f++"_ffi :: CString -> IO CString",
         f++"_ffi cstr = do",
        "        str <- peekCString cstr",
--        "        putStrLn str",
        "        let",
        "            argtup :: "++ftype_tup,
        "            argtup = read str",
        if (length args == 1) 
          then
            "            " ++ (head args) ++ " = argtup"          
          else
            "            (" ++ (joinWith args ",") ++ ") = argtup",
        if (length args == 1) 
          then             
            "            retval =  "++f++" "++ (head args)
          else  
            "            retval =  "++f++" "++(unwords args),          
        "            retval_str = showToPerl $ show retval", 
        "        cstr' <- newCString retval_str",
        "        return cstr'" 
    ]
      
  
joinWith (fstr:strs) sep = foldl (\acc str -> acc ++" "++sep++" "++str) fstr strs

ffi_c_h_lines func_list = 
  let
        tups = map gen_c_h func_list
  in        
        (unlines $ (map (\x -> x++";") (map fst tups)), unlines $ map snd tups)

gen_c_h (f,ft,fs,fht) =
    let    
      ffi_arg_types = init ft
      ffi_res_type = last ft
      args = map (\i -> "x"++(show i)) [1 .. length ffi_arg_types]
      c_args = map c_ffi_arg_conversion (zip args ffi_arg_types)
      res_ctype = c_ffi_res_conversion ffi_res_type
      c_sig = res_ctype++" "++f++"_ffi_c("++(joinWith c_args ", ")++")"
      c_code=unlines [
          c_sig
          ,"{"
  --        ,"    printf(\"BEFORE FFI call in C wrapper\\n\");"
          ,"    "++res_ctype++" res = "++f++"_ffi("++(joinWith args ", ")++");"
          ,"    return res;"
          ,"}"
        ]
    in
      (c_sig, c_code)
 
c_ffi_arg_conversion (x,t)
    | t == "CLong" = "long "++x
    | t == "CInt" = "int "++x
    | t == "CDouble" = "double "++x
    | t == "CString" = "char* "++x
    | otherwise = error $ "Type "++t++" not supported"
    
c_ffi_res_conversion t
    | t == "IO CLong" = "long "
    | t == "IO CInt" = "int "
    | t == "IO CDouble" = "double "
    | t == "IO CString" = "char* "
    | otherwise = error $ "Type "++t++" not supported"
    




