Merge pull request #3009 from gaborigloi/ppx-ely

Finish moving to ppx-based syntax extensions

OMakeroot

@@ -74,17 +74,6 @@ OCamlLibraryClib(name, files, clibs) =
 
    return $(array $(if $(NATIVE_ENABLED), $(NATIVELIB)), $(if $(NATIVE_ENABLED), $(CLIB)), $(if $(BYTE_ENABLED), $(BYTELIB)))
 
-#
-# Use Camlp4
-#
-UseCamlp4(packs, files) =
-       OCAMLPACKS     += $(packs)
-       OCAMLFINDFLAGS += -syntax camlp4o
-       $(addsuffix .cmx, $(files)):
-       $(addsuffix .o, $(files)):
-       $(addsuffix .cmi, $(files)):
-       $(addsuffix .cmo, $(files)):
-
 #
 # Include the OMakefile in this directory.
 #

ocaml/autogen/OMakefile

@@ -7,8 +7,6 @@ OCAMLPACKS    = xml-light2 sexpr http-svr xcp rpclib
 clean:
 	rm -rf *.*
 
-UseCamlp4(rpclib.syntax, aPI)
-
 DB_ACTIONS_FILES = db_actions $(AUTOGEN_HELPER_DIR)/string_unmarshall_helper $(AUTOGEN_HELPER_DIR)/string_marshall_helper $(AUTOGEN_HELPER_DIR)/db_action_helper $(AUTOGEN_HELPER_DIR)/db_remote_marshall $(AUTOGEN_HELPER_DIR)/db_filter_types $(AUTOGEN_HELPER_DIR)/db_filter $(AUTOGEN_HELPER_DIR)/db_filter_parse $(AUTOGEN_HELPER_DIR)/db_filter_lex
 OCamlProgram(db_actions, $(DB_ACTIONS_FILES))
 

ocaml/doc/OMakefile

@@ -1,9 +1,6 @@
 OCAML_LIBS += ../idl/datamodel
 OCAMLINCLUDES += ../idl
 
-CAMLP4_FILES = jsapi
-UseCamlp4(rpclib.syntax, $(CAMLP4_FILES))
-
 OCamlProgram(jsapi, jsapi)
 
 .PHONY: doc-html

ocaml/doc/jsapi.ml

@@ -16,7 +16,7 @@ open Datamodel_types
 
 type change_t = lifecycle_change * string * string
 and changes_t = change_t list
-with rpc
+[@@deriving rpc]
 
 let _ =
   let api = (Datamodel.all_api) in

ocaml/idl/OMakefile

@@ -5,10 +5,6 @@ PSTOPDF = $(shell bash -c "which pstopdf 2>/dev/null || which ps2pdf 2>/dev/null
 OCAMLINCLUDES  = ocaml_backend ../database
 OCAMLPACKS     = xml-light2 sexpr xcp rpclib http-svr uuid
 
-CAMLP4_FILES = datamodel_types
-
-UseCamlp4(rpclib.syntax, $(CAMLP4_FILES))
-
 # -----------------------------------------------------------------------
 # Build datamodel library
 # -----------------------------------------------------------------------

ocaml/idl/datamodel_types.ml

@@ -98,7 +98,7 @@ type ty =
   | Map of ty * ty
   | Ref of string
   | Record of string
-with rpc
+[@@deriving rpc]
 
 type api_value =
     VString of string
@@ -111,7 +111,7 @@ type api_value =
   | VSet of api_value list
   | VRef of string
   | VCustom of string * api_value
-with rpc
+[@@deriving rpc]
 
 (** Each database field has a qualifier associated with it:
   * "Static" means the initial value is specified as a parameter in the object constructor.
@@ -122,14 +122,14 @@ type qualifier =
   | RW        (** Implicitly static: set in constructor and updatable through API *)
   | StaticRO  (** Specified in constructor; no autogenerated setter in XenAPI. *)
   | DynamicRO (** Initial value is a default; no autogenerated setter in XenAPI. *)
-with rpc
+[@@deriving rpc]
 
 (** Release keeps track of which versions of opensource/internal products fields and messages are included in *)
 type release = {
   opensource: string list;
   internal: string list;
   internal_deprecated_since: string option; (* first release we said it was deprecated *)
-} with rpc
+} [@@deriving rpc]
 
 type lifecycle_change =
   | Prototyped
@@ -140,7 +140,7 @@ type lifecycle_change =
   | Removed
 
 and lifecycle_transition = lifecycle_change * string * string
-with rpc
+[@@deriving rpc]
 
 (** Messages are tagged with one of these indicating whether the message was
     specified explicitly in the datamodel, or is one of the automatically
@@ -219,7 +219,7 @@ and error = {
 and mess = {
   mess_name: string;
   mess_doc: string;
-} with rpc
+} [@@deriving rpc]
 
 let default_message = {
   msg_name = "";
@@ -258,12 +258,12 @@ let default_message = {
 type content =
   | Field of field                     (** An individual field *)
   | Namespace of string * content list (** A nice namespace for a group of fields *)
-with rpc
+[@@deriving rpc]
 
 (* Note: there used be more than 2 persist_options -- that's why it isn't a bool.
    I figured even though there's only 2 now I may as well leave it as an enumeration type.. *)
 
-type persist_option = PersistNothing | PersistEverything with rpc
+type persist_option = PersistNothing | PersistEverything [@@deriving rpc]
 (* PersistEverything - all creates/writes persisted;
    PersistNothing - no creates/writes to this table persisted *)
 
@@ -285,7 +285,7 @@ type obj = {
   obj_release: release;
   in_database: bool; (* If the object is in the database *)
   obj_doc_tags: doc_tag list;
-} with rpc
+} [@@deriving rpc]
 
 (* val rpc_of_obj : obj -> Rpc.t *)
 (* let s = Jsonrpc.to_string (rpc_of_obj o) *)

ocaml/idl/json_backend/OMakefile

@@ -4,9 +4,6 @@ OCAML_LIBS += ../datamodel
 
 OCamlProgram(main, main)
 
-CAMLP4_FILES = main
-UseCamlp4(rpclib.syntax, $(CAMLP4_FILES))
-
 .PHONY: clean
 clean:
         rm -f *~ *.opt *.run *.a *.cma *.cmxa *.cmo *.cmi *.o *.cmx *.omc *.annot main *.json

ocaml/idl/ocaml_backend/OMakefile

@@ -11,10 +11,6 @@ OCAMLINCLUDES += ../.. ../../database $(AUTOGEN_DIR) ../../xapi ../../client_rec
 
 OCAMLPACKS += sexpr xml-light2 http-svr rpclib stunnel
 
-CAMLP4_FILES = event_types
-
-UseCamlp4(rpclib.syntax, $(CAMLP4_FILES))
-
 # only gen_api requires datamodel library:
 GEN_API_FILES = gen_api gen_test genOCaml ref ocaml_syntax gen_db_actions gen_db_check gen_empty_custom gen_client gen_server gen_common gen_rbac ../../database/escaping locking ../api_lowlevel gen_api_main ../datamodel ../constants ../api_errors ../api_messages ../datamodel_utils ../datamodel_values ocaml_utils ../datamodel_types ../dm_api $(AUTOGEN_HELPER_DIR)/string_marshall_helper
 OCamlProgram(gen_api_main, $(GEN_API_FILES))

ocaml/idl/ocaml_backend/event_types.ml

@@ -25,7 +25,7 @@ type event = {
   op: op;
   reference: string;
   snapshot: Rpc.t option;
-} with rpc
+} [@@deriving rpc]
 
 let ev_struct_remap = [
   "id","id";
@@ -48,15 +48,15 @@ let rpc_of_event ev =
 let event_of_rpc rpc =
   event_of_rpc (remap (List.map (fun (k,v) -> (v,k)) ev_struct_remap) rpc)
 
-type events = event list with rpc
+type events = event list [@@deriving rpc]
 
-type token = string with rpc
+type token = string [@@deriving rpc]
 
 type event_from = {
   events: event list;
   valid_ref_counts: (string * int32) list;
   token: token;
-} with rpc
+} [@@deriving rpc]
 
 let rec rpc_of_event_from e =
   Rpc.Dict

ocaml/idl/ocaml_backend/gen_api.ml

@@ -57,12 +57,12 @@ let gen_non_record_type highapi tys =
     | DT.Map (_, DT.Record _) :: t
     | DT.Set (DT.Record _)    :: t -> aux accu t
     | DT.Set (DT.Enum (n,_) as e) as ty :: t ->
-      aux (sprintf "type %s = %s list with rpc" (OU.alias_of_ty ty) (OU.alias_of_ty e) :: accu) t
+      aux (sprintf "type %s = %s list [@@deriving rpc]" (OU.alias_of_ty ty) (OU.alias_of_ty e) :: accu) t
     | ty                      :: t ->
       let alias = OU.alias_of_ty ty in
       if List.mem_assoc alias overrides
       then aux ((sprintf "type %s = %s\n%s\n" alias (OU.ocaml_of_ty ty) (List.assoc alias overrides))::accu) t
-      else aux (sprintf "type %s = %s with rpc" (OU.alias_of_ty ty) (OU.ocaml_of_ty ty) :: accu) t in
+      else aux (sprintf "type %s = %s [@@deriving rpc]" (OU.alias_of_ty ty) (OU.ocaml_of_ty ty) :: accu) t in
   aux [] tys
 
 (** Generate a list of modules for each record kind *)
@@ -93,8 +93,8 @@ let gen_record_type ~with_module highapi tys =
         else [
           sprintf "let rpc_of_%s_t x = Rpc.Dict [ %s ]" obj_name (map_fields make_of_field);
           sprintf "let %s_t_of_rpc x = on_dict (fun x -> { %s }) x" obj_name (map_fields make_to_field);
-          sprintf "type ref_%s_to_%s_t_map = (ref_%s * %s_t) list with rpc" record obj_name record obj_name;
-          sprintf "type %s_t_set = %s_t list with rpc" obj_name obj_name;
+          sprintf "type ref_%s_to_%s_t_map = (ref_%s * %s_t) list [@@deriving rpc]" record obj_name record obj_name;
+          sprintf "type %s_t_set = %s_t list [@@deriving rpc]" obj_name obj_name;
           ""
         ] in
       aux (type_t :: others @ accu) t
@@ -131,14 +131,14 @@ let gen_client_types highapi =
   List.iter (List.iter print)
     (List.between [""] [
         [
-          "type failure = (string list) with rpc";
+          "type failure = (string list) [@@deriving rpc]";
           "let response_of_failure code params =";
           "  Rpc.failure (rpc_of_failure (code::params))";
           "let response_of_fault code =";
           "  Rpc.failure (rpc_of_failure ([\"Fault\"; code]))";
         ]; [
           "include Rpc";
-          "type string_list = string list with rpc";
+          "type string_list = string list [@@deriving rpc]";
         ]; [
           "module Ref = struct";
           "  include Ref";

ocaml/license/OMakefile

@@ -2,8 +2,6 @@ OCAML_LIBS    = ../util/xapi_version ../idl/ocaml_backend/xapi_client
 OCAMLINCLUDES = ../idl/ocaml_backend ../idl ../autogen ../xapi ../gpg ../util
 OCAMLPACKS    = xml-light2 stdext stunnel http-svr xcp rpclib uuid systemd
 
-UseCamlp4(rpclib.syntax, v6rpc v6errors)
-
 # Name of programs to install in dom0:
 DAILY_LICENSE_CHECK = daily-license-check
 

ocaml/xapi/OMakefile

@@ -11,10 +11,6 @@ OCAMLINCLUDES = ../idl ../idl/ocaml_backend \
 	../xva ../util \
 	../auth ../license ../client_records ../rfb ../gpg
 
-UseCamlp4(rpclib.syntax, features storage_impl xapi_udhcpd storage_migrate \
-          xapi_services system_domains cancel_tests config_file_sync updates \
-          sparse_dd_wrapper vhd_tool_wrapper)
-
 CFLAGS += -std=gnu99 -Wall -Werror -I$(shell ocamlc -where)
 
 #XENLIGHT_LINK_FLAGS= -cclib -lxlutil -cclib -luuid -cclib -lblktapctl -cclib -lutil -cclib -lxenlight -cclib -lxenstore
@@ -43,7 +39,7 @@ OCAMLPACKS = $(OCAMLPACKS) $(XEN_OCAMLPACKS)
 OCamlProgram(http_test, http_test)
 OCamlProgram(show_bat, show_bat)
 
-OCamlProgram(storage_impl_test, sparse_encoding sparse_dd_wrapper storage_migrate storage_impl task_server updates storage_task storage_locks storage_impl_test)
+OCamlProgram(storage_impl_test, sparse_encoding sparse_dd_wrapper storage_migrate storage_impl task_server updates storage_task storage_locks storage_impl_test rpc_std_helpers)
 
 COMMON = \
 	xapi_templates \
@@ -53,6 +49,7 @@ COMMON = \
 	xapi_mgmt_iface \
 	smint \
 	../gpg/gpg \
+	rpc_std_helpers \
 	helpers \
 	at_least_once_more \
 	fileserver

ocaml/xapi/cancel_tests.ml

@@ -69,7 +69,7 @@ type operation =
   | VBD_unplug
   | VIF_plug
   | VIF_unplug
-with rpc
+[@@deriving rpc]
 
 let operations = [
   VBD_plug

ocaml/xapi/config_file_sync.ml

@@ -20,7 +20,7 @@ open Stdext.Xstringext
 
 let superuser = "root"
 
-type config = { password : string } with rpc
+type config = { password : string } [@@deriving rpc]
 
 (* Increment this if config type changes *)
 let config_sync_version = 2

ocaml/xapi/features.ml

@@ -54,7 +54,7 @@ type feature =
   | Live_patching
   | Live_set_vcpus
   | PVS_proxy
-with rpc
+[@@deriving rpc]
 
 type orientation = Positive | Negative
 

ocaml/xapi/rpc_std_helpers.ml

@@ -0,0 +1,11 @@
+let rpc_of_hashtbl ~rpc_of t =
+  let dict = Hashtbl.fold (fun k v acc -> (k, rpc_of v) :: acc) t [] in
+  Rpc.Dict dict
+
+let hashtbl_of_rpc ~of_rpc = function
+  | Rpc.Dict d ->
+    let h = Hashtbl.create (List.length d) in
+    List.iter (function (k, r) -> Hashtbl.add h k (of_rpc r)) d;
+    h
+  | r -> failwith (Printf.sprintf "Expected Rpc.Dict, but got %s" (Xmlrpc.to_string r))
+

ocaml/xapi/rpc_std_helpers.mli

@@ -0,0 +1,5 @@
+(** Helpers to marshal and unmarshal Rpc.Dict into Hashtbl *)
+
+val rpc_of_hashtbl : rpc_of:('a -> Rpc.t) -> (string, 'a) Hashtbl.t -> Rpc.t
+
+val hashtbl_of_rpc : of_rpc:(Rpc.t -> 'a) -> Rpc.t -> (string, 'a) Hashtbl.t

ocaml/xapi/sparse_dd_wrapper.ml

@@ -37,7 +37,7 @@ type t = {
 
 (* Store sparse_dd pids on disk so we can kill them after a xapi restart *)
 module State = struct
-  type pids = int list with rpc
+  type pids = int list [@@deriving rpc]
 
   let filename = ref "/var/run/nonpersistent/xapi/sparse_dd_pids.json"
 

ocaml/xapi/storage_impl.ml

@@ -98,7 +98,7 @@ let info  (fmt: ('a, unit, string, unit) format4) = if !print_debug then log_to_
 let host_state_path = ref "/var/run/nonpersistent/xapi/storage.db"
 
 module Dp = struct
-  type t = string with rpc
+  type t = string [@@deriving rpc]
   let make username = username
 end
 
@@ -112,7 +112,7 @@ module Vdi = struct
     attach_info :  attach_info option;    (** Some path when attached; None otherwise *)
     dps: (Dp.t * Vdi_automaton.state) list; (** state of the VDI from each dp's PoV *)
     leaked: Dp.t list;                        (** "leaked" dps *)
-  } with rpc
+  } [@@deriving rpc]
   let empty () = {
     attach_info = None;
     dps = [];
@@ -159,11 +159,14 @@ end
 
 module Sr = struct
   (** Represents the state of an SR *)
-  type vdis = (string, Vdi.t) Hashtbl.t with rpc
+  type vdis = (string, Vdi.t) Hashtbl.t
+
+  let vdis_of_rpc = Rpc_std_helpers.hashtbl_of_rpc ~of_rpc:Vdi.t_of_rpc
+  let rpc_of_vdis = Rpc_std_helpers.rpc_of_hashtbl ~rpc_of:Vdi.rpc_of_t
 
   type t = {
     vdis: vdis; (** All tracked VDIs *)
-  } with rpc
+  } [@@deriving rpc]
 
   let empty () = {
     vdis = Hashtbl.create 10;
@@ -181,10 +184,15 @@ module Sr = struct
 end
 
 module Host = struct
+  type srs = (string, Sr.t) Hashtbl.t
+
+  let srs_of_rpc = Rpc_std_helpers.hashtbl_of_rpc ~of_rpc:Sr.t_of_rpc
+  let rpc_of_srs = Rpc_std_helpers.rpc_of_hashtbl ~rpc_of:Sr.rpc_of_t
+
   (** Represents the state of a host *)
   type t = {
-    srs: (string, Sr.t) Hashtbl.t;
-  } with rpc
+    srs: srs;
+  } [@@deriving rpc]
 
   let empty () = {
     srs = Hashtbl.create 10
@@ -207,9 +215,9 @@ module Errors = struct
     sr: string;
     vdi: string;
     error: string
-  } with rpc
+  } [@@deriving rpc]
 
-  type t = error list with rpc
+  type t = error list [@@deriving rpc]
 
   let max = 100
   let errors = ref []
@@ -234,7 +242,7 @@ module Everything = struct
   type t = {
     host: Host.t;
     errors: Errors.t;
-  } with rpc
+  } [@@deriving rpc]
 
   let make () = { host = !Host.host; errors = !Errors.errors }