let pr fs = ksprintf (output_string !chan) fs
(* Generate a header block in a number of standard styles. *)
-type comment_style = CStyle | HashStyle | OCamlStyle
+type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle
type license = GPLv2 | LGPLv2
let generate_header comment license =
let c = match comment with
| CStyle -> pr "/* "; " *"
| HashStyle -> pr "# "; "#"
- | OCamlStyle -> pr "(* "; " *" in
+ | OCamlStyle -> pr "(* "; " *"
+ | HaskellStyle -> pr "{- "; " " in
pr "libguestfs generated file\n";
pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
| CStyle -> pr " */\n"
| HashStyle -> ()
| OCamlStyle -> pr " *)\n"
+ | HaskellStyle -> pr "-}\n"
);
pr "\n"
croak (\"array reference expected\");
av = (AV *)SvRV (arg);
- ret = malloc (av_len (av) + 1 + 1);
+ ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
if (!ret)
croak (\"malloc failed\");
pr " guestfs_free_lvm_%s_list (r);\n" typ;
pr " return jr;\n"
+and generate_haskell_hs () =
+ generate_header HaskellStyle LGPLv2;
+
+ (* XXX We only know how to generate partial FFI for Haskell
+ * at the moment. Please help out!
+ *)
+ let can_generate style =
+ let check_no_bad_args =
+ List.for_all (function Bool _ | Int _ -> false | _ -> true)
+ in
+ match style with
+ | RErr, args -> check_no_bad_args args
+ | RBool _, _
+ | RInt _, _
+ | RInt64 _, _
+ | RConstString _, _
+ | RString _, _
+ | RStringList _, _
+ | RIntBool _, _
+ | RPVList _, _
+ | RVGList _, _
+ | RLVList _, _
+ | RStat _, _
+ | RStatVFS _, _
+ | RHashtable _, _ -> false in
+
+ pr "\
+{-# INCLUDE <guestfs.h> #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Guestfs (
+ create";
+
+ (* List out the names of the actions we want to export. *)
+ List.iter (
+ fun (name, style, _, _, _, _, _) ->
+ if can_generate style then pr ",\n %s" name
+ ) all_functions;
+
+ pr "
+ ) where
+import Foreign
+import Foreign.C
+import IO
+import Control.Exception
+import Data.Typeable
+
+data GuestfsS = GuestfsS -- represents the opaque C struct
+type GuestfsP = Ptr GuestfsS -- guestfs_h *
+type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
+
+-- XXX define properly later XXX
+data PV = PV
+data VG = VG
+data LV = LV
+data IntBool = IntBool
+data Stat = Stat
+data StatVFS = StatVFS
+data Hashtable = Hashtable
+
+foreign import ccall unsafe \"guestfs_create\" c_create
+ :: IO GuestfsP
+foreign import ccall unsafe \"&guestfs_close\" c_close
+ :: FunPtr (GuestfsP -> IO ())
+foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
+ :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
+
+create :: IO GuestfsH
+create = do
+ p <- c_create
+ c_set_error_handler p nullPtr nullPtr
+ h <- newForeignPtr c_close p
+ return h
+
+foreign import ccall unsafe \"guestfs_last_error\" c_last_error
+ :: GuestfsP -> IO CString
+
+-- last_error :: GuestfsH -> IO (Maybe String)
+-- last_error h = do
+-- str <- withForeignPtr h (\\p -> c_last_error p)
+-- maybePeek peekCString str
+
+last_error :: GuestfsH -> IO (String)
+last_error h = do
+ str <- withForeignPtr h (\\p -> c_last_error p)
+ if (str == nullPtr)
+ then return \"no error\"
+ else peekCString str
+
+";
+
+ (* Generate wrappers for each foreign function. *)
+ List.iter (
+ fun (name, style, _, _, _, _, _) ->
+ if can_generate style then (
+ pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
+ pr " :: ";
+ generate_haskell_prototype ~handle:"GuestfsP" style;
+ pr "\n";
+ pr "\n";
+ pr "%s :: " name;
+ 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)));
+ pr " r <- ";
+ List.iter (
+ function
+ | FileIn n
+ | FileOut n
+ | String n -> pr "withCString %s $ \\%s -> " n n
+ | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
+ | StringList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
+ | Bool n ->
+ (* XXX this doesn't work *)
+ pr " let\n";
+ pr " %s = case %s of\n" n n;
+ pr " False -> 0\n";
+ pr " True -> 1\n";
+ pr " in fromIntegral %s $ \\%s ->\n" n n
+ | Int n -> pr "fromIntegral %s $ \\%s -> " n n
+ ) (snd style);
+ pr "withForeignPtr h (\\p -> c_%s %s)\n" name
+ (String.concat " " ("p" :: List.map name_of_argt (snd style)));
+ (match fst style with
+ | RErr | RInt _ | RInt64 _ | RBool _ ->
+ pr " if (r == -1)\n";
+ pr " then do\n";
+ pr " err <- last_error h\n";
+ pr " fail err\n";
+ | RConstString _ | RString _ | RStringList _ | RIntBool _
+ | RPVList _ | RVGList _ | RLVList _ | RStat _ | RStatVFS _
+ | RHashtable _ ->
+ pr " if (r == nullPtr)\n";
+ pr " then do\n";
+ pr " err <- last_error h\n";
+ pr " fail err\n";
+ );
+ (match fst style with
+ | RErr ->
+ pr " else return ()\n"
+ | RInt _ ->
+ pr " else return (fromIntegral r)\n"
+ | RInt64 _ ->
+ pr " else return (fromIntegral r)\n"
+ | RBool _ ->
+ pr " else return (toBool r)\n"
+ | RConstString _
+ | RString _
+ | RStringList _
+ | RIntBool _
+ | RPVList _
+ | RVGList _
+ | RLVList _
+ | RStat _
+ | RStatVFS _
+ | RHashtable _ ->
+ pr " else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
+ );
+ pr "\n";
+ )
+ ) all_functions
+
+and generate_haskell_prototype ~handle ?(hs = false) style =
+ pr "%s -> " handle;
+ let string = if hs then "String" else "CString" in
+ let int = if hs then "Int" else "CInt" in
+ let bool = if hs then "Bool" else "CInt" in
+ let int64 = if hs then "Integer" else "Int64" in
+ List.iter (
+ fun arg ->
+ (match arg with
+ | String _ -> pr "%s" string
+ | OptString _ -> if hs then pr "Maybe String" else pr "CString"
+ | StringList _ -> if hs then pr "[String]" else pr "Ptr CString"
+ | Bool _ -> pr "%s" bool
+ | Int _ -> pr "%s" int
+ | FileIn _ -> pr "%s" string
+ | FileOut _ -> pr "%s" string
+ );
+ pr " -> ";
+ ) (snd style);
+ pr "IO (";
+ (match fst style with
+ | RErr -> if not hs then pr "CInt"
+ | RInt _ -> pr "%s" int
+ | RInt64 _ -> pr "%s" int64
+ | RBool _ -> pr "%s" bool
+ | RConstString _ -> pr "%s" string
+ | RString _ -> pr "%s" string
+ | RStringList _ -> pr "[%s]" string
+ | RIntBool _ -> pr "IntBool"
+ | RPVList _ -> pr "[PV]"
+ | RVGList _ -> pr "[VG]"
+ | RLVList _ -> pr "[LV]"
+ | RStat _ -> pr "Stat"
+ | RStatVFS _ -> pr "StatVFS"
+ | RHashtable _ -> pr "Hashtable"
+ );
+ pr ")"
+
let output_to filename =
let filename_new = filename ^ ".new" in
chan := open_out filename_new;
let close = output_to "java/com_redhat_et_libguestfs_GuestFS.c" in
generate_java_c ();
close ();
+
+ let close = output_to "haskell/Guestfs.hs" in
+ generate_haskell_hs ();
+ close ();
git.annexia.org / libguestfs.git / blobdiff