[Libguestfs] [UNFINISHED PATCHES] Make optional arguments work in Haskell
Richard W.M. Jones
rjones at redhat.com
Wed Jan 16 05:04:44 UTC 2013
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
-------------- next part --------------
>From 1933f694d7fc94c2c8dc0f61605fb67c1378bbc0 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones at 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
-------------- next part --------------
>From aa454c50e84652bc2f7326657fe291c93f1a97d5 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones at 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
More information about the Libguestfs
mailing list