[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]

[Libguestfs] [UNFINISHED PATCHES] Make optional arguments work in Haskell



These patches are incomplete, and I don't intend to work on this
any further at the moment.  I am posting them here to archive them.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
libguestfs lets you edit virtual machines.  Supports shell scripting,
bindings from many languages.  http://libguestfs.org
>From 1933f694d7fc94c2c8dc0f61605fb67c1378bbc0 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones redhat com>
Date: Sat, 29 Dec 2012 19:32:48 +0000
Subject: [PATCH 1/2] HASKELL OPTIONAL ARGUMENTS

---
 generator/haskell.ml        | 128 +++++++++++++++++++++++++++++++++++++-------
 haskell/Guestfs030Config.hs |   4 +-
 2 files changed, 110 insertions(+), 22 deletions(-)

diff --git a/generator/haskell.ml b/generator/haskell.ml
index abd0478..1b0e982 100644
--- a/generator/haskell.ml
+++ b/generator/haskell.ml
@@ -35,19 +35,18 @@ let rec generate_haskell_hs () =
    * bindings.  Please help out! XXX
    *)
   let can_generate = function
-    | _, _, (_::_) -> false (* no optional args yet *)
-    | RErr, _, []
-    | RInt _, _, []
-    | RInt64 _, _, []
-    | RBool _, _, []
-    | RConstString _, _, []
-    | RString _, _, []
-    | RStringList _, _, []
-    | RHashtable _, _, [] -> true
-    | RStruct _, _, []
-    | RStructList _, _, []
-    | RBufferOut _, _, []
-    | RConstOptString _, _, [] -> false
+    | RErr, _, _
+    | RInt _, _, _
+    | RInt64 _, _, _
+    | RBool _, _, _
+    | RConstString _, _, _
+    | RString _, _, _
+    | RStringList _, _, _
+    | RHashtable _, _, _ -> true
+    | RStruct _, _, _
+    | RStructList _, _, _
+    | RBufferOut _, _, _
+    | RConstOptString _, _, _ -> false
   in
 
   pr "\
@@ -62,6 +61,19 @@ module Guestfs (
       if can_generate style then pr ",\n  %s" name
   ) all_functions;
 
+  (* Export 'def' and optional arguments. *)
+  pr ",\n  def";
+  List.iter (
+    function
+    | { name = name; style = (_, _, (_::_ as optargs) as style) }
+        when can_generate style ->
+      List.iter (
+        fun optarg -> pr ",\n  set_%s_%s" name (name_of_optargt optarg)
+      ) optargs
+    | _ -> ()
+  ) all_functions;
+
+
   pr "
   ) where
 
@@ -73,6 +85,7 @@ import Prelude hiding (head, tail, truncate)
 import Foreign
 import Foreign.C
 import Foreign.C.Types
+import Foreign.Storable
 import System.IO
 import Control.Exception
 import Data.Typeable
@@ -116,24 +129,93 @@ assocListOfHashtable [a] =
   fail \"RHashtable returned an odd number of elements\"
 assocListOfHashtable (a:b:rest) = (a,b) : assocListOfHashtable rest
 
+-- Optional arguments.
+-- http://neilmitchell.blogspot.co.uk/2008/04/optional-parameters-in-haskell.html
+class Def a where
+  def :: a
+
 ";
 
   (* Generate wrappers for each foreign function. *)
   List.iter (
     fun { name = name; style = (ret, args, optargs as style);
+          camel_name = camel_name;
           c_function = c_function } ->
       if can_generate style then (
+        if optargs <> [] then (
+          pr "data %s_optargs =\n" camel_name;
+          pr "  %s_optargs {" camel_name;
+          let comma = ref false in
+          List.iter (
+            fun optarg ->
+              if !comma then pr ",";
+              comma := true;
+              pr "\n";
+              pr "    set_%s_%s :: " name (name_of_optargt optarg);
+              match optarg with
+              | OBool _ -> pr "Maybe Bool"
+              | OInt _ -> pr "Maybe Int"
+              | OInt64 _ -> pr "Maybe Int64"
+              | OString _ -> pr "Maybe String"
+              | OStringList _ -> pr "Maybe [String]"
+          ) optargs;
+          pr "\n  }\n";
+          pr "\n";
+
+          pr "def%s =\n" name;
+          pr "  %s_optargs" camel_name;
+          List.iter (fun _ -> pr " Nothing") optargs;
+          pr "\n";
+          pr "\n";
+
+          pr "instance Def %s_optargs where\n" camel_name;
+          pr "  def = def%s\n" name;
+          pr "\n";
+
+          pr "instance Storable %s_optargs where\n" camel_name;
+          pr "  sizeOf _ = error \"SIZEOF NOT IMPL\"\n";
+          pr "  alignment _ = error \"ALIGNMENT NOT IMPL\"\n";
+          pr "  poke ptr = error \"POKE %s NOT IMPLEMENTED\"\n" camel_name;
+          pr "\n";
+
+          pr "data %s_argv =\n" camel_name;
+          pr "  %s_argv {\n" camel_name;
+          pr "    argv_%s_bitmask :: Int64" name;
+          List.iter (
+            fun optarg ->
+              pr ",\n";
+              pr "    argv_%s_%s :: " name (name_of_optargt optarg);
+              match optarg with
+              | OBool _ -> pr "Int"
+              | OInt _ -> pr "Int"
+              | OInt64 _ -> pr "Int64"
+              | OString _ -> pr "CString"
+              | OStringList _ -> pr "[CString]"
+          ) optargs;
+          pr "\n  }\n";
+          pr "\n";
+
+          pr "make%s_argv :: %s_optargs -> Ptr %s_argv\n"
+            camel_name camel_name camel_name;
+          pr "make%s_argv =\n" camel_name;
+          pr "    error \"MAKE ARGV %s NOT IMPL\"\n" camel_name;
+          pr "\n";
+        );
+
         pr "foreign import ccall unsafe \"guestfs.h %s\" c_%s\n"
           c_function name;
         pr "  :: ";
-        generate_haskell_prototype ~handle:"GuestfsP" style;
+        generate_haskell_prototype ~handle:"GuestfsP" camel_name style;
         pr "\n";
         pr "\n";
         pr "%s :: " name;
-        generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
+        generate_haskell_prototype ~handle:"GuestfsH" ~hs:true camel_name style;
         pr "\n";
-        pr "%s %s = do\n" name
-          (String.concat " " ("h" :: List.map name_of_argt args));
+        pr "%s %s%s = do\n" name
+          (String.concat " " ("h" :: List.map name_of_argt args))
+          (if optargs <> [] then " optargs" else "");
+        if optargs <> [] then
+          pr "  argv <- return (make%s_argv optargs)\n" camel_name;
         pr "  r <- ";
         (* Convert pointer arguments using with* functions. *)
         List.iter (
@@ -162,8 +244,9 @@ assocListOfHashtable (a:b:rest) = (a,b) : assocListOfHashtable rest
             | Key n -> n
             | BufferIn n -> sprintf "%s (fromIntegral %s_size)" n n
           ) args in
-        pr "withForeignPtr h (\\p -> c_%s %s)\n" name
-          (String.concat " " ("p" :: args));
+        pr "withForeignPtr h (\\p -> c_%s %s%s)\n" name
+          (String.concat " " ("p" :: args))
+          (if optargs <> [] then " argv" else "");
         (match ret with
          | RErr | RInt _ | RInt64 _ | RBool _ ->
              pr "  if (r == -1)\n";
@@ -207,7 +290,8 @@ assocListOfHashtable (a:b:rest) = (a,b) : assocListOfHashtable rest
       )
   ) all_functions
 
-and generate_haskell_prototype ~handle ?(hs = false) (ret, args, optargs) =
+and generate_haskell_prototype ~handle ?(hs = false) camel_name
+    (ret, args, optargs) =
   pr "%s -> " handle;
   if not hs then (
     List.iter (
@@ -230,6 +314,8 @@ and generate_haskell_prototype ~handle ?(hs = false) (ret, args, optargs) =
         );
         pr " -> ";
     ) args;
+    if optargs <> [] then
+      pr "Ptr %s_argv -> " camel_name;
     pr "IO ";
     (match ret with
     | RErr -> pr "CInt"
@@ -271,6 +357,8 @@ and generate_haskell_prototype ~handle ?(hs = false) (ret, args, optargs) =
         );
         pr " -> ";
     ) args;
+    if optargs <> [] then
+      pr "%s_optargs -> " camel_name;
     pr "IO ";
     (match ret with
     | RErr -> pr "()"
diff --git a/haskell/Guestfs030Config.hs b/haskell/Guestfs030Config.hs
index 69c474d..311b89d 100644
--- a/haskell/Guestfs030Config.hs
+++ b/haskell/Guestfs030Config.hs
@@ -41,5 +41,5 @@ main = do
   when (p == "") $
     fail "path is empty"
 
-  G.add_drive_ro g "/dev/null"
-  G.add_drive_ro g "/dev/zero"
+  G.add_drive g "/dev/null" G.def{G.set_add_drive_readonly = Just True}
+  G.add_drive g "/dev/zero" G.def{G.set_add_drive_readonly = Just True}
-- 
1.8.0.1

>From aa454c50e84652bc2f7326657fe291c93f1a97d5 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones redhat com>
Date: Tue, 15 Jan 2013 18:38:42 +0000
Subject: [PATCH 2/2] HASKELL OPTIONAL ARGUMENTS 2

---
 generator/haskell.ml | 154 +++++++++++++++++++++++++++++++--------------------
 1 file changed, 93 insertions(+), 61 deletions(-)

diff --git a/generator/haskell.ml b/generator/haskell.ml
index 1b0e982..a53fc54 100644
--- a/generator/haskell.ml
+++ b/generator/haskell.ml
@@ -89,6 +89,7 @@ import Foreign.Storable
 import System.IO
 import Control.Exception
 import Data.Typeable
+import Data.Bits
 
 data GuestfsS = GuestfsS            -- represents the opaque C struct
 type GuestfsP = Ptr GuestfsS        -- guestfs_h *
@@ -138,69 +139,14 @@ class Def a where
 
   (* Generate wrappers for each foreign function. *)
   List.iter (
-    fun { name = name; style = (ret, args, optargs as style);
+    fun ({ name = name; style = (ret, args, optargs as style);
           camel_name = camel_name;
-          c_function = c_function } ->
+          c_function = c_function } as f) ->
+      pr "-- Haskell binding for guestfs_%s\n" name;
+      pr "\n";
+
       if can_generate style then (
-        if optargs <> [] then (
-          pr "data %s_optargs =\n" camel_name;
-          pr "  %s_optargs {" camel_name;
-          let comma = ref false in
-          List.iter (
-            fun optarg ->
-              if !comma then pr ",";
-              comma := true;
-              pr "\n";
-              pr "    set_%s_%s :: " name (name_of_optargt optarg);
-              match optarg with
-              | OBool _ -> pr "Maybe Bool"
-              | OInt _ -> pr "Maybe Int"
-              | OInt64 _ -> pr "Maybe Int64"
-              | OString _ -> pr "Maybe String"
-              | OStringList _ -> pr "Maybe [String]"
-          ) optargs;
-          pr "\n  }\n";
-          pr "\n";
-
-          pr "def%s =\n" name;
-          pr "  %s_optargs" camel_name;
-          List.iter (fun _ -> pr " Nothing") optargs;
-          pr "\n";
-          pr "\n";
-
-          pr "instance Def %s_optargs where\n" camel_name;
-          pr "  def = def%s\n" name;
-          pr "\n";
-
-          pr "instance Storable %s_optargs where\n" camel_name;
-          pr "  sizeOf _ = error \"SIZEOF NOT IMPL\"\n";
-          pr "  alignment _ = error \"ALIGNMENT NOT IMPL\"\n";
-          pr "  poke ptr = error \"POKE %s NOT IMPLEMENTED\"\n" camel_name;
-          pr "\n";
-
-          pr "data %s_argv =\n" camel_name;
-          pr "  %s_argv {\n" camel_name;
-          pr "    argv_%s_bitmask :: Int64" name;
-          List.iter (
-            fun optarg ->
-              pr ",\n";
-              pr "    argv_%s_%s :: " name (name_of_optargt optarg);
-              match optarg with
-              | OBool _ -> pr "Int"
-              | OInt _ -> pr "Int"
-              | OInt64 _ -> pr "Int64"
-              | OString _ -> pr "CString"
-              | OStringList _ -> pr "[CString]"
-          ) optargs;
-          pr "\n  }\n";
-          pr "\n";
-
-          pr "make%s_argv :: %s_optargs -> Ptr %s_argv\n"
-            camel_name camel_name camel_name;
-          pr "make%s_argv =\n" camel_name;
-          pr "    error \"MAKE ARGV %s NOT IMPL\"\n" camel_name;
-          pr "\n";
-        );
+        if optargs <> [] then generate_optargs f;
 
         pr "foreign import ccall unsafe \"guestfs.h %s\" c_%s\n"
           c_function name;
@@ -290,6 +236,92 @@ class Def a where
       )
   ) all_functions
 
+and generate_optargs { name = name;
+                       style = ret, args, optargs;
+                       camel_name = camel_name } =
+  pr "data %s_optargs =\n" camel_name;
+  pr "  %s_optargs {" camel_name;
+  let comma = ref false in
+  List.iter (
+    fun optarg ->
+      if !comma then pr ",";
+      comma := true;
+      pr "\n";
+      pr "    set_%s_%s :: " name (name_of_optargt optarg);
+      match optarg with
+      | OBool _ -> pr "Maybe Bool"
+      | OInt _ -> pr "Maybe Int"
+      | OInt64 _ -> pr "Maybe Int64"
+      | OString _ -> pr "Maybe String"
+      | OStringList _ -> pr "Maybe [String]"
+  ) optargs;
+  pr "\n  }\n";
+  pr "\n";
+
+  pr "def%s =\n" name;
+  pr "  %s_optargs" camel_name;
+  List.iter (fun _ -> pr " Nothing") optargs;
+  pr "\n";
+  pr "\n";
+
+  pr "instance Def %s_optargs where\n" camel_name;
+  pr "  def = def%s\n" name;
+  pr "\n";
+
+  pr "data %s_argv =\n" camel_name;
+  pr "  %s_argv {\n" camel_name;
+  pr "    argv_%s_bitmask :: Int64" name;
+  List.iter (
+    fun optarg ->
+      pr ",\n";
+      pr "    argv_%s_%s :: " name (name_of_optargt optarg);
+      match optarg with
+      | OBool _ -> pr "Int"
+      | OInt _ -> pr "Int"
+      | OInt64 _ -> pr "Int64"
+      | OString _ -> pr "CString"
+      | OStringList _ -> pr "[CString]"
+  ) optargs;
+  pr "\n  }\n";
+  pr "\n";
+
+  pr "instance Storable %s_argv where\n" camel_name;
+  pr "  sizeOf _ = error \"SIZEOF NOT IMPL\"\n";
+  pr "  alignment _ = error \"ALIGNMENT NOT IMPL\"\n";
+  pr "  poke ptr = error \"POKE %s NOT IMPLEMENTED\"\n" camel_name;
+  pr "\n";
+
+  pr "make%s_argv :: %s_optargs -> Ptr %s_argv\n"
+    camel_name camel_name camel_name;
+  pr "make%s_argv optargs =\n" camel_name;
+  pr "  let zero = 0 :: Integer in\n";
+  pr "  let bitmask =";
+  let orop = ref false in
+  iteri (
+    fun i optarg ->
+      if !orop then pr " .|.";
+      orop := true;
+      pr " if set_%s_%s optargs == Nothing then zero else (1 `shiftL` %d)"
+        name (name_of_optargt optarg) i
+  ) optargs;
+  pr " in\n";
+  pr "  %s_argv {\n" camel_name;
+  pr "    argv_%s_bitmask = bitmask" name;
+  let comma = ref false in
+  List.iter (
+    fun optarg ->
+      let n = name_of_optargt optarg in
+      if !comma then pr ",";
+      comma := true;
+      pr "\n";
+      pr "    argv_%s_%s =" name n;
+      pr " case set_%s_%s optargs of\n" name n;
+      pr "      Nothing -> 0\n";
+      pr "      Just n -> n";
+  ) optargs;
+  pr "  }\n";
+  pr "\n"
+
 and generate_haskell_prototype ~handle ?(hs = false) camel_name
     (ret, args, optargs) =
   pr "%s -> " handle;
-- 
1.8.0.1


[Date Prev][Date Next]   [Thread Prev][Thread Next]   [Thread Index] [Date Index] [Author Index]