Partial Haskell bindings.

1 files changed, 209 insertions, 2 deletions

diff --git a/src/generator.ml b/src/generator.ml
index 5b6e1eb3..f7057d0e 100755
--- a/src/generator.ml
+++ b/src/generator.ml
@@ -2214,14 +2214,15 @@ let chan = ref stdout
 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;
@@ -2263,6 +2264,7 @@ let generate_header comment license =
    | CStyle -> pr " */\n"
    | HashStyle -> ()
    | OCamlStyle -> pr " *)\n"
+   | HaskellStyle -> pr "-}\n"
   );
   pr "\n"
 
@@ -6528,6 +6530,207 @@ and generate_java_lvm_return typ jtyp cols =
   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;
@@ -6668,3 +6871,7 @@ Run it from the top source directory using the command
   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 ();