Richard W.M. Jones
2013-Jan-16 05:04 UTC
[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 people.redhat.com/~rjones libguestfs lets you edit virtual machines. Supports shell scripting, bindings from many languages. libguestfs.org -------------- next part -------------->From 1933f694d7fc94c2c8dc0f61605fb67c1378bbc0 Mon Sep 17 00:00:00 2001From: "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. +-- 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 2001From: "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
Apparently Analagous Threads
- Re: [PATCH v6 2/3] mllib: modify nsplit to take optional noempty and count arguments
- [PATCH 0/2] Add mkfs-opts API with optional arguments
- [PATCH] Protocol changes to support upload progress messages and optional arguments.
- Re: [PATCH v6 2/3] mllib: modify nsplit to take optional noempty and count arguments
- Re: [PATCH libnbd 0/2] Two patches to make libnbd work on FreeBSD.