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