>From aa454c50e84652bc2f7326657fe291c93f1a97d5 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" 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