X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=generator%2Fgenerator_haskell.ml;h=29b260f2f23c84d4916b6dbc5e7df8acc990bc9b;hp=a125cbd59eb755dfc70a8146157d4ee50f3ef88c;hb=7739d7f471f9575828bd32489695d92dde005a9c;hpb=04d8209077d2227eb1d42695ba71147f78987050

diff --git a/generator/generator_haskell.ml b/generator/generator_haskell.ml
index a125cbd..29b260f 100644
--- a/generator/generator_haskell.ml
+++ b/generator/generator_haskell.ml
@@ -36,18 +36,19 @@ let rec generate_haskell_hs () =
    *)
   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> #-}
@@ -73,7 +74,7 @@ import Prelude hiding (truncate)
 import Foreign
 import Foreign.C
 import Foreign.C.Types
-import IO
+import System.IO
 import Control.Exception
 import Data.Typeable
 
@@ -123,7 +124,7 @@ last_error h = do
 
   (* 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 "  :: ";
@@ -134,7 +135,7 @@ last_error h = do
         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 (
@@ -147,25 +148,25 @@ last_error h = do
               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";
@@ -179,7 +180,7 @@ last_error h = do
              pr "      err <- last_error h\n";
              pr "      fail err\n";
         );
-        (match fst style with
+        (match ret with
          | RErr ->
              pr "    else return ()\n"
          | RInt _ ->
@@ -202,7 +203,7 @@ last_error h = do
       )
   ) 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
@@ -221,13 +222,14 @@ and generate_haskell_prototype ~handle ?(hs = false) style =
        | 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