*)
let can_generate style =
match style with
- | RErr, _
- | RInt _, _
- | RInt64 _, _ -> true
- | RBool _, _
- | RConstString _, _
- | RConstOptString _, _
- | RString _, _
- | RStringList _, _
- | RStruct _, _
- | RStructList _, _
- | RHashtable _, _
- | RBufferOut _, _ -> false in
+ | _, _, (_::_) -> false (* no optional args yet *)
+ | RErr, _, []
+ | RInt _, _, []
+ | RInt64 _, _, [] -> true
+ | RBool _, _, []
+ | RConstString _, _, []
+ | RConstOptString _, _, []
+ | RString _, _, []
+ | RStringList _, _, []
+ | RStruct _, _, []
+ | RStructList _, _, []
+ | RHashtable _, _, []
+ | RBufferOut _, _, [] -> false in
pr "\
{-# INCLUDE <guestfs.h> #-}
(* Generate wrappers for each foreign function. *)
List.iter (
- fun (name, style, _, _, _, _, _) ->
+ fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
if can_generate style then (
pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
pr " :: ";
generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
pr "\n";
pr "%s %s = do\n" name
- (String.concat " " ("h" :: List.map name_of_argt (snd style)));
+ (String.concat " " ("h" :: List.map name_of_argt args));
pr " r <- ";
(* Convert pointer arguments using with* functions. *)
List.iter (
pr "withCStringLen %s $ \\(%s, %s_size) -> " n n n
| OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
| StringList n | DeviceList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
- | Bool _ | Int _ | Int64 _ -> ()
- ) (snd style);
+ | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
+ ) args;
(* Convert integer arguments. *)
let args =
List.map (
function
| Bool n -> sprintf "(fromBool %s)" n
| Int n -> sprintf "(fromIntegral %s)" n
- | Int64 n -> sprintf "(fromIntegral %s)" n
+ | Int64 n | Pointer (_, n) -> sprintf "(fromIntegral %s)" n
| FileIn n | FileOut n
| Pathname n | Device n | Dev_or_Path n
| String n | OptString n
| StringList n | DeviceList n
| Key n -> n
| BufferIn n -> sprintf "%s (fromIntegral %s_size)" n n
- ) (snd style) in
+ ) args in
pr "withForeignPtr h (\\p -> c_%s %s)\n" name
(String.concat " " ("p" :: args));
- (match fst style with
+ (match ret with
| RErr | RInt _ | RInt64 _ | RBool _ ->
pr " if (r == -1)\n";
pr " then do\n";
pr " err <- last_error h\n";
pr " fail err\n";
);
- (match fst style with
+ (match ret with
| RErr ->
pr " else return ()\n"
| RInt _ ->
)
) all_functions
-and generate_haskell_prototype ~handle ?(hs = false) style =
+and generate_haskell_prototype ~handle ?(hs = false) (ret, args, optargs) =
pr "%s -> " handle;
let string = if hs then "String" else "CString" in
let int = if hs then "Int" else "CInt" in
| Bool _ -> pr "%s" bool
| Int _ -> pr "%s" int
| Int64 _ -> pr "%s" int
+ | Pointer _ -> pr "%s" int
| FileIn _ -> pr "%s" string
| FileOut _ -> pr "%s" string
);
pr " -> ";
- ) (snd style);
+ ) args;
pr "IO (";
- (match fst style with
+ (match ret with
| RErr -> if not hs then pr "CInt"
| RInt _ -> pr "%s" int
| RInt64 _ -> pr "%s" int64