Re: [Libguestfs] [PATCH 3/3] daemon: autogenerate most of OCaml interfaces

diff --git a/generator/daemon.ml b/generator/daemon.ml index 7fb7052a0..03b191ac8 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -490,6 +490,91 @@ let generate_daemon_caml_callbacks_ml () = else pr "let init_callbacks () = ()\n" +let rec generate_daemon_caml_interface modname () = + generate_header OCamlStyle GPLv2plus; + + let is_ocaml_module_function = function + | { impl = OCaml m } when String.is_prefix m (modname ^ ".") -> true + | { impl = OCaml _ } -> false + | { impl = C } -> false + in + + let ocaml_actions = actions |> (List.filter is_ocaml_module_function) in + if ocaml_actions == [] then + failwithf "no OCaml implementations for module %s" modname; + + let prefix_length = String.length modname + 1 in + List.iter ( + fun ({ name; style } as f) -> + let ocaml_function = + match f.impl with + | OCaml f -> String.sub f prefix_length (String.length f - prefix_length) + | C -> assert false in + + generate_ocaml_daemon_prototype ocaml_function style + ) ocaml_actions + +and generate_ocaml_daemon_prototype name style = + pr "val %s : " name; + generate_ocaml_daemon_function_type style; + pr "\n" + +and generate_ocaml_daemon_function_type (ret, args, optargs) = + let type_for_stringt = function + | Mountable + | Mountable_or_Path -> "Mountable.t" + | PlainString + | Device + | Pathname + | FileIn + | FileOut + | Key + | GUID + | Filename + | Dev_or_Path -> "string" + in + let type_for_rstringt = function + | RMountable -> "Mountable.t" + | RPlainString + | RDevice -> "string" + in + List.iter ( + function + | OBool n -> pr "?%s:bool -> " n + | OInt n -> pr "?%s:int -> " n + | OInt64 n -> pr "?%s:int64 -> " n + | OString n -> pr "?%s:string -> " n + | OStringList n -> pr "?%s:string array -> " n + ) optargs; + if args <> [] then + List.iter ( + function + | String (typ, _)-> pr "%s -> " (type_for_stringt typ) + | BufferIn _ -> pr "string -> " + | OptString _ -> pr "string option -> " + | StringList (typ, _)-> pr "%s array -> " (type_for_stringt typ) + | Bool _ -> pr "bool -> " + | Int _ -> pr "int -> " + | Int64 _ | Pointer _ -> pr "int64 -> " + ) args + else + pr "unit -> "; + (match ret with + | RErr -> pr "unit" (* all errors are turned into exceptions *) + | RInt _ -> pr "int" + | RInt64 _ -> pr "int64" + | RBool _ -> pr "bool" + | RConstString _ -> pr "string" + | RConstOptString _ -> pr "string option" + | RString (typ, _) -> pr "%s" (type_for_rstringt typ) + | RBufferOut _ -> pr "string" + | RStringList (typ, _) -> pr "%s list" (type_for_rstringt typ) + | RStruct (_, typ) -> pr "Structs.%s" typ + | RStructList (_, typ) -> pr "Structs.%s list" typ + | RHashtable (typea, typeb, _) -> + pr "(%s * %s) list" (type_for_rstringt typea) (type_for_rstringt typeb) + ) + (* Generate stubs for the functions implemented in OCaml. * Basically we implement the do_<name> function here, and * have it call out to OCaml code.

diff --git a/generator/main.ml b/generator/main.ml index 34bca68d9..ed75d1005 100644 --- a/generator/main.ml +++ b/generator/main.ml @@ -46,6 +46,11 @@ let output_to_subset fs f = for i = 0 to nr_actions_files-1 do ksprintf (fun filename -> output_to filename (f actions_subsets.(i))) fs i done +let output_to_ocaml_daemon modname = + let fn = Char.escaped (Char.lowercase_ascii (String.unsafe_get modname 0)) ^ + String.sub modname 1 (String.length modname - 1) in + output_to (sprintf "daemon/%s.mli" fn) + (Daemon.generate_daemon_caml_interface modname) (* Main program. *) let () = @@ -155,6 +160,11 @@ Run it from the top source directory using the command Daemon.generate_daemon_structs_cleanups_c; output_to "daemon/structs-cleanups.h" Daemon.generate_daemon_structs_cleanups_h; + let daemon_ocaml_interfaces = [ + "Blkid"; "Btrfs"; "Devsparts"; "File"; "Filearch"; "Findfs"; "Inspect"; + "Is"; "Ldm"; "Link"; "Listfs"; "Md"; "Parted"; "Realpath"; "Statvfs"; + ] in

+ List.iter output_to_ocaml_daemon daemon_ocaml_interfaces;

output_to "fish/cmds-gperf.gperf" Fish.generate_fish_cmds_gperf; -- 2.14.3 _______________________________________________ Libguestfs mailing list Libguestfs(a)redhat.com https://www.redhat.com/mailman/listinfo/libguestfs