The value library is part of the ocaml-orm project available here: http://github.com/avsm/ocaml-orm-sqlite
This backport improves multiple points of the value library (which will be upstreamed later), like the polymorphic type variables or the type variable with module names (ie. 'type t = 'a M.tt with rpc' will work). Basically, all the types used by xapi are handles + some minor extensions as objects.
Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
libs: $(LIBS)
test_forker: test_forker.cmx
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../uuid -I ../stdext uuid.cmxa jsonrpc.cmxa -I ../log unix.cmxa stdext.cmxa test_forker.cmx -o $@
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../uuid -I ../stdext uuid.cmxa rpc.cmx jsonrpc.cmx -I ../log unix.cmxa stdext.cmxa test_forker.cmx -o $@
fe: fe_debug.cmx child.cmx fe_main.cmx
- $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../stdext -I ../uuid -I ../log log.cmxa uuid.cmxa unix.cmxa jsonrpc.cmxa stdext.cmxa fe_debug.cmx child.cmx fe_main.cmx -o $@
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../rpc-light -I ../stdext -I ../uuid -I ../log log.cmxa uuid.cmxa unix.cmxa rpc.cmx jsonrpc.cmx stdext.cmxa fe_debug.cmx child.cmx fe_main.cmx -o $@
%.cmo: %.ml
$(OCAMLC) -c -I ../log -I ../uuid -I ../stdext -thread -o $@ $<
+++ /dev/null
-version = "0.1"
-description = "JSON-RPC marshalling/unmarshalling"
-archive(byte) = "jsonrpc.cma"
-archive(native) = "jsonrpc.cmxa"
+++ /dev/null
-version = "0.1"
-description = "RPC light: lightweight library to convert plain ML types to and from RPC values"
-
-package "syntax"
- (
- version = "0.1"
- description = "pa-rpc: library to marshalling/unmarshalling ML types to/from Rpc.t"
- requires = "type-conv.syntax"
- archive(syntax,preprocessor) = "pa_rpc.cma"
- archive(syntax,toploop) = "pa_rpc.cma"
- )
\ No newline at end of file
+++ /dev/null
-version = "0.1"
-description = "XML-RPC marshalling/unmarshalling"
-requires = "xmlm"
-archive(byte) = "xmlrpc.cma"
-archive(native) = "xmlrpc.cmxa"
OCAMLFLAGS = -annot -g
PACKS = xmlm
-ICAMLP4=-I $(shell ocamlfind query camlp4) -I $(shell ocamlfind query type-conv)
-
-DOCDIR = /myrepos/xen-api-libs.hg/doc
+ICAMLP4 = -I $(shell ocamlfind query camlp4) -I $(shell ocamlfind query type-conv)
+DOCDIR = /myrepos/xen-api-libs.hg/doc
+TARGETS = \
+ rpc.cmi rpc.cmo rpc.o rpc.cmx \
+ pa_rpc.cma \
+ xmlrpc.cmi xmlrpc.cmo xmlrpc.o xmlrpc.cmx \
+ jsonrpc.cmi jsonrpc.cmo jsonrpc.o jsonrpc.cmx
.PHONY: all clean
-all: pa_rpc.cma xmlrpc.cmi xmlrpc.cma xmlrpc.cmxa jsonrpc.cmi jsonrpc.cmxa jsonrpc.cma
-
+all: $(TARGETS)
-pa_rpc.cma: rpc.cmo pa_rpc.cmo
+pa_rpc.cma: rpc.cmo p4_rpc.cmo pa_rpc.cmo
$(OCAMLC) -a $(ICAMLP4) -o $@ $^
-pa_rpc.cmo: pa_rpc.ml
+pa_rpc.cmo: pa_rpc.ml p4_rpc.cmo
$(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $<
+p4_rpc.cmo: p4_rpc.ml rpc.cmo
+ $(OCAMLC) $(OCAMLFLAGS) -c -package camlp4,type-conv -pp "camlp4orf" $(ICAMLP4) $@ $<
-
-rpc.cmx: rpc.ml
- $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
-
-rpc.cmo: rpc.ml
- $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
-
-
-
-%.cmxa: rpc.cmx %.cmx
- $(OCAMLOPT) -a -o $@ $^
-
-%.cma: rpc.cmo %.cmo
- $(OCAMLC) -a -o $@ $^
-
-
-
-xmlrpc.cmx: xmlrpc.ml xmlrpc.cmi rpc.ml
+%.o %.cmx: %.ml
$(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
-xmlrpc.cmo: xmlrpc.ml xmlrpc.cmi rpc.ml
+%.cmo: %.ml
$(OCAMLC) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
-xmlrpc.cmi: xmlrpc.mli rpc.ml
+%.cmi: %.mli %.ml
$(OCAMLOPT) $(OCAMLFLAGS) -package $(PACKS) -c -o $@ $<
-
-jsonrpc.cmx: jsonrpc.ml jsonrpc.cmi rpc.ml
- $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
-
-jsonrpc.cmo: jsonrpc.ml jsonrpc.cmi rpc.ml
- $(OCAMLC) $(OCAMLFLAGS) -c -o $@ $<
-
-jsonrpc.cmi: jsonrpc.mli rpc.ml
- $(OCAMLOPT) $(OCAMLFLAGS) -c -o $@ $<
-
-
.PHONY: install
-install: path = $(DESTDIR)$(shell ocamlfind printconf destdir)
-install: rpc.cmi pa_rpc.cma xmlrpc.cma xmlrpc.cmxa
- mkdir -p $(path)
- cp META-xmlrpc META
- ocamlfind install -destdir $(path) xmlrpc META xmlrpc.cma xmlrpc.cmxa xmlrpc.cmi rpc.cmi xmlrpc.cmx rpc.cmx xmlrpc.a xmlrpc.o
- cp META-jsonrpc META
- ocamlfind install -destdir $(path) jsonrpc META jsonrpc.cma jsonrpc.cmxa jsonrpc.cmi rpc.cmi jsonrpc.cmx rpc.cmx jsonrpc.a jsonrpc.o
- cp META-rpc-light META
- ocamlfind install -destdir $(path) rpc-light META pa_rpc.cma pa_rpc.cmi
- rm META
+install: INSTALL_PATH = $(DESTDIR)$(shell ocamlfind printconf destdir)
+install: all
+ ocamlfind install -destdir $(INSTALL_PATH) rpc-light META $(TARGETS)
.PHONY: uninstall
uninstall:
- ocamlfind remove xmlrpc
- ocamlfind remove jsonrpc
ocamlfind remove rpc-light
.PHONY: doc
doc: $(INTF)
python ../doc/doc.py $(DOCDIR) "rpc-light" "package" "jsonrpc pa_rpc rpc xmlrpc" "." "xmlm" ""
-
+
clean:
rm -f *.cmo *.cmx *.cma *.cmxa *.annot *.o *.cmi *.a
OCAMLOPT = ocamlfind ocamlopt
OCAMLFLAGS = -annot -g
-PACKS = xmlrpc,jsonrpc
+PACKS = rpc-light
EXAMPLES = all_types
EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
type t = Foo of int | Bar of (int * float) with rpc
-type x = {
- foo: t;
+module M = struct
+ type m = t with rpc
+end
+
+type 'a x = {
+ foo: M.m;
bar: string;
gna: float list;
f1: (int option * bool list * float list list) option;
f4: int64;
f5: int;
f6: (unit * char) list;
+ f7: 'a list;
progress: int array;
} with rpc
let _ =
- let x1 = {
+ let x = {
foo= Foo 3;
bar= "ha ha";
gna=[1.; 2.; 3.; 4. ];
f2 = [| "hi",["hi"]; "hou",["hou";"hou"]; "foo", ["b";"a";"r"] |];
- f1 = None;
+ f1 = Some (None, [true], [[1.]; [2.;3.]]);
f3 = Int32.max_int;
f4 = Int64.max_int;
f5 = max_int;
f6 = [ (),'a' ; (),'b' ; (),'c'; (),'d' ; (),'e' ];
+ f7 = [ Foo 1; Foo 2; Foo 3 ];
progress = [| 0; 1; 2; 3; 4; 5 |];
} in
- let rpc = rpc_of_x x1 in
- let xml = Xmlrpc.to_string rpc in
- let json = Jsonrpc.to_string rpc in
+ (* Testing basic marshalling/unmarshalling *)
+
+ let rpc = rpc_of_x M.rpc_of_m x in
+
+ let rpc_xml = Xmlrpc.to_string rpc in
+ let rpc_json = Jsonrpc.to_string rpc in
- Printf.printf "xmlrpc: %s\n\n" xml;
- Printf.printf "jsonrpc: %s\n\n" json;
+ Printf.printf "\n==rpc_xml==\n%s\n" rpc_xml;
+ Printf.printf "\n==json==\n%s\n" rpc_json;
let callback fields value = match (fields, value) with
- | ["progress"], `Int i -> Printf.printf "Progress: %Ld\n" i
+ | ["progress"], Rpc.Int i -> Printf.printf "Progress: %Ld\n" i
| _ -> ()
in
- let x2 = x_of_rpc (Xmlrpc.of_string ~callback xml) in
- let x3 = x_of_rpc (Jsonrpc.of_string json) in
+ let x_xml = x_of_rpc M.m_of_rpc (Xmlrpc.of_string ~callback rpc_xml) in
+ let x_json = x_of_rpc M.m_of_rpc (Jsonrpc.of_string rpc_json) in
- Printf.printf "\nSanity check 1:\nx1=x2: %b\nx2=x3: %b\nx1=x3: %b\n\n" (x1 = x2) (x2 = x3) (x1 = x3);
+ Printf.printf "\n==Sanity check 1==\nx=x_xml: %b\nx=x_json: %b\n" (x = x_xml) (x = x_json);
+ assert (x = x_xml && x = x_json);
+
+ (* Testing calls and responses *)
- let call = { Rpc.name = "foo"; Rpc.params = [ rpc ] } in
- let response1 = Rpc.Success rpc in
- let response2 = Rpc.Fault (1L, "Foo") in
- let response3 = Rpc.Fault rpc in
+ let call = Rpc.call "foo" [ rpc; Rpc.String "Mouhahahaaaaa" ] in
+ let success = Rpc.success rpc in
+ let failure = Rpc.failure rpc in
- let c1 = Xmlrpc.string_of_call call in
- let r1 = Xmlrpc.string_of_response response1 in
- let r2 = Xmlrpc.string_of_response response2 in
+ let c_xml_str = Xmlrpc.string_of_call call in
+ let s_xml_str = Xmlrpc.string_of_response success in
+ let f_xml_str = Xmlrpc.string_of_response failure in
- let cj1 = Jsonrpc.string_of_call call in
- let rj1 = Jsonrpc.string_of_response 0L response1 in
- let rj3 = Jsonrpc.string_of_response 0L response3 in
+ let c_json_str = Jsonrpc.string_of_call call in
+ let s_json_str = Jsonrpc.string_of_response success in
+ let f_json_str = Jsonrpc.string_of_response failure in
- Printf.printf "call: %s\n%s\n" c1 cj1;
- Printf.printf "response1: %s\n%s\n" r1 rj1;
- Printf.printf "response2: %s\n" r2;
- Printf.printf "response3: %s\n" rj3;
+ Printf.printf "\n==call==\n %s\n%s\n" c_xml_str c_json_str;
+ Printf.printf "\n==success==\n %s\n%s\n" s_xml_str s_json_str;
+ Printf.printf "\n==failure==\n %s\n%s\n" f_xml_str f_json_str;
- let c1' = Xmlrpc.call_of_string c1 in
- let r1' = Xmlrpc.response_of_string r1 in
- let r2' = Xmlrpc.response_of_string r2 in
+ let c_xml = Xmlrpc.call_of_string c_xml_str in
+ let s_xml = Xmlrpc.response_of_string s_xml_str in
+ let f_xml = Xmlrpc.response_of_string f_xml_str in
- Printf.printf "\nSanity check 2:\ncall=c1': %b\nresponse1=r1': %b\nresponse2=r2': %b\n"
- (call = c1') (response1 = r1') (response2 = r2');
+ (* Printf.printf "\n==Sanity check 2==\ncall=c_xml: %b\nsuccess=s_xml: %b\nfailure=f_xml: %b\n"
+ (call = c_xml) (success = s_xml) (failure = f_xml);
+ assert (call = c_xml && success = s_xml && failure = f_xml); *)
- let _, cj1' = Jsonrpc.call_of_string cj1 in
- let _, rj1' = Jsonrpc.response_of_string rj1 in
- let _, rj3' = Jsonrpc.response_of_string rj3 in
+ let c_json = Jsonrpc.call_of_string c_json_str in
+ let s_json = Jsonrpc.response_of_string s_json_str in
+ let f_json = Jsonrpc.response_of_string f_json_str in
- Printf.printf "\nSanity check 3:\ncall=cj1': %b\nresponse1=rj1': %b\nresponse3=rj3': %b\n"
- (call = cj1') (response1 = rj1') (response3 = rj3');
+ Printf.printf "\n==Sanity check 3==\ncall=c_json': %b\nsuccess=s_json': %b\nfailure=f_json': %b\n"
+ (call = c_json) (success = s_json) (failure = f_json);
+ assert (call = c_json && success = s_json && failure = f_json)
let rec to_fct t f =
match t with
- | `Int i -> f (Printf.sprintf "%Ld" i)
- | `Bool b -> f (string_of_bool b)
- | `Float r -> f (Printf.sprintf "%f" r)
- | `String s -> f (escape_string s)
- | `None -> f "null"
- | `List a ->
+ | Int i -> f (Printf.sprintf "%Ld" i)
+ | Bool b -> f (string_of_bool b)
+ | Float r -> f (Printf.sprintf "%f" r)
+ | String s -> f (escape_string s)
+ | Null -> f "null"
+ | Enum a ->
f "[";
list_iter_between (fun i -> to_fct i f) (fun () -> f ", ") a;
f "]";
- | `Dict a ->
+ | Dict a ->
f "{";
- list_iter_between (fun (k, v) -> to_fct (`String k) f; f ": "; to_fct v f)
+ list_iter_between (fun (k, v) -> to_fct (String k) f; f ": "; to_fct v f)
(fun () -> f ", ") a;
f "}"
(fun () -> count := Int64.add 1L !count; !count)
let string_of_call call =
- let json = `Dict [
- "method", `String call.name;
- "params", `List call.params;
- "id", `Int (new_id ());
+ let json = Dict [
+ "method", String call.name;
+ "params", Enum call.params;
+ "id", Int (new_id ());
] in
to_string json
let string_of_response response =
let json =
if response.Rpc.success then
- `Dict [
+ Dict [
"result", response.Rpc.contents;
- "error", `None;
- "id", `Int 0L
+ "error", Null;
+ "id", Int 0L
]
else
- `Dict [
- "result", `None;
+ Dict [
+ "result", Null;
"error", response.Rpc.contents;
- "id", `Int 0L
+ "id", Int 0L
] in
to_string json
| Expect_object_elem_colon
| Expect_comma_or_end
| Expect_object_key
- | Done of Val.t
+ | Done of t
type int_value =
- | IObject of (string * Val.t) list
- | IObject_needs_key of (string * Val.t) list
- | IObject_needs_value of (string * Val.t) list * string
- | IArray of Val.t list
+ | IObject of (string * t) list
+ | IObject_needs_key of (string * t) list
+ | IObject_needs_value of (string * t) list * string
+ | IArray of t list
type parse_state = {
mutable cursor: cursor;
let finish_value s v =
match s.stack, v with
| [], _ -> s.cursor <- Done v
- | IObject_needs_key fields :: tl, `String key ->
+ | IObject_needs_key fields :: tl, String key ->
s.stack <- IObject_needs_value (fields, key) :: tl;
s.cursor <- Expect_object_elem_colon
| IObject_needs_value (fields, key) :: tl, _ ->
let pop_stack s =
match s.stack with
- | IObject fields :: tl -> s.stack <- tl; finish_value s (`Dict (List.rev fields))
- | IArray l :: tl -> s.stack <- tl; finish_value s (`List (List.rev l))
+ | IObject fields :: tl -> s.stack <- tl; finish_value s (Dict (List.rev fields))
+ | IArray l :: tl -> s.stack <- tl; finish_value s (Enum (List.rev l))
| io :: tl -> raise_internal_error s ("unexpected " ^ (ivalue_to_str io) ^ " on stack at pop_stack")
| [] -> raise_internal_error s "empty stack at pop_stack"
let str = tostring_with_leading_zero_check is in
let int = try Int64.of_string str
with Failure _ -> raise_invalid_value s str "int" in
- finish_value s (`Int int) in
+ finish_value s (Int int) in
let finish_int_exp is es =
let int = tostring_with_leading_zero_check is in
let exp = clist_to_string (List.rev es) in
returning float is more uniform. *)
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (`Float float) in
+ finish_value s (Float float) in
let finish_float is fs =
let int = tostring_with_leading_zero_check is in
let frac = clist_to_string (List.rev fs) in
let str = Printf.sprintf "%s.%s" int frac in
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (`Float float) in
+ finish_value s (Float float) in
let finish_float_exp is fs es =
let int = tostring_with_leading_zero_check is in
let frac = clist_to_string (List.rev fs) in
let str = Printf.sprintf "%s.%se%s" int frac exp in
let float = try float_of_string str
with Failure _ -> raise_invalid_value s str "float" in
- finish_value s (`Float float) in
+ finish_value s (Float float) in
match s.cursor with
| Start ->
(match c, rem with
| 'u', 3 -> s.cursor <- In_null 2
| 'l', 2 -> s.cursor <- In_null 1
- | 'l', 1 -> finish_value s `None
+ | 'l', 1 -> finish_value s Null
| _ -> raise_unexpected_char s c "null")
| In_true rem ->
(match c, rem with
| 'r', 3 -> s.cursor <- In_true 2
| 'u', 2 -> s.cursor <- In_true 1
- | 'e', 1 -> finish_value s (`Bool true)
+ | 'e', 1 -> finish_value s (Bool true)
| _ -> raise_unexpected_char s c "true")
| In_false rem ->
| 'a', 4 -> s.cursor <- In_false 3
| 'l', 3 -> s.cursor <- In_false 2
| 's', 2 -> s.cursor <- In_false 1
- | 'e', 1 -> finish_value s (`Bool false)
+ | 'e', 1 -> finish_value s (Bool false)
| _ -> raise_unexpected_char s c "false")
| In_int is ->
| In_string cs ->
(match c with
| '\\' -> s.cursor <- In_string_control cs
- | '"' -> finish_value s (`String (clist_to_string (List.rev cs)))
+ | '"' -> finish_value s (String (clist_to_string (List.rev cs)))
| _ when is_valid_unescaped_char c -> s.cursor <- In_string (c :: cs)
| _ -> raise_unexpected_char s c "string")
| Expect_object_elem_start ->
(match c with
| '"' -> s.stack <- (IObject_needs_key []) :: s.stack; s.cursor <- In_string []
- | '}' -> finish_value s (`Dict [])
+ | '}' -> finish_value s (Dict [])
| _ when is_space c -> update_line_num s c
| _ -> raise_unexpected_char s c "object_start")
| Done _ -> raise_internal_error s "parse called when parse_state is 'Done'"
type parse_result =
- | Json_value of Val.t * (* number of consumed bytes *) int
+ | Json_value of t * (* number of consumed bytes *) int
| Json_parse_incomplete of parse_state
let parse_substring state str ofs len =
let call_of_string str =
match of_string str with
- | `Dict d ->
- let name = match get "method" d with `String s -> s | _ -> raise (Malformed_method_request str) in
- let params = match get "params" d with `List l -> l | _ -> raise (Malformed_method_request str) in
- let (_:int64) = match get "id" d with `Int i -> i | _ -> raise (Malformed_method_request str) in
- { name = name; params = params }
+ | Dict d ->
+ let name = match get "method" d with String s -> s | _ -> raise (Malformed_method_request str) in
+ let params = match get "params" d with Enum l -> l | _ -> raise (Malformed_method_request str) in
+ let (_:int64) = match get "id" d with Int i -> i | _ -> raise (Malformed_method_request str) in
+ call name params
| _ -> raise (Malformed_method_request str)
let response_of_string str =
match of_string str with
- | `Dict d ->
+ | Dict d ->
let result = get "result" d in
let error = get "error" d in
- let (_:int64) = match get "id" d with `Int i -> i | _ -> raise (Malformed_method_response str) in
+ let (_:int64) = match get "id" d with Int i -> i | _ -> raise (Malformed_method_response str) in
begin match result, error with
- | `None, `None -> raise (Malformed_method_response str)
- | `None, v -> { Rpc.success = false; contents = v }
- | v, `None -> { Rpc.success = true; contents = v }
- | _ -> raise (Malformed_method_response str)
+ | Null, Null -> raise (Malformed_method_response str)
+ | Null, v -> failure v
+ | v, Null -> success v
+ | _ -> raise (Malformed_method_response str)
end
| _ -> raise (Malformed_method_response str)
* GNU Lesser General Public License for more details.
*)
-val to_string : Rpc.Val.t -> string
-val of_string : string -> Rpc.Val.t
+val to_string : Rpc.t -> string
+val of_string : string -> Rpc.t
val string_of_call: Rpc.call -> string
val call_of_string: string -> Rpc.call
open Ast
open Syntax
-
-let is_base = function
- | "int64" | "int32" | "int" | "float" | "string" | "unit" -> true
- | _ -> false
-
let rpc_of n = "rpc_of_" ^ n
-
let of_rpc n = n ^ "_of_rpc"
let rpc_of_polyvar a = "__rpc_of_" ^ a ^ "__"
let new_id_list _loc l =
List.split (List.map (fun _ -> new_id _loc) l)
+exception Type_not_supported of ctyp
let type_not_supported ty =
let module PP = Camlp4.Printers.OCaml.Make(Syntax) in
let pp = new PP.printer () in
Format.eprintf "Type %a@. not supported.\n%!" pp#ctyp ty;
- failwith "type not supported by rpc-light"
+ failwith "type_not_supported"
let apply _loc fn fn_i create id modules t a =
let args = decompose_args _loc a in
expr
args
-let is_option = function
- | <:ctyp@loc< option $_$ >> -> true
- | _ -> false
-
-let is_string _loc key =
- if key = "string" then
- <:expr< True >>
- else if is_base key then
- <:expr< False >>
- else <:expr< try let ( _ : $lid:key$ ) = $lid:of_rpc key$ (Rpc.String "") in True with [ _ -> False ] >>
-
(* Conversion ML type -> Rpc.value *)
module Rpc_of = struct
- let rec product get_field t =
- let _loc = loc_of_ctyp t in
- let fields = decompose_fields _loc t in
- let ids, pids = new_id_list _loc fields in
- let bindings = List.map2 (fun pid (f, _) -> <:binding< $pid$ = $get_field f$ >>) pids fields in
- let aux nid (n, ctyp) accu =
- if is_option ctyp then begin
- let new_id, new_pid = new_id _loc in
- <:expr<
- match $create nid ctyp$ with [
- Rpc.Enum [] -> $accu$
- | Rpc.Enum [ $new_pid$ ] -> [ ($str:n$, $new_id$) :: $accu$ ]
- | _ -> assert False
- ] >>
- end else
- <:expr< [ ($str:n$, $create nid ctyp$) :: $accu$ ] >> in
- let expr = <:expr< Rpc.Dict $List.fold_right2 aux ids fields <:expr< [] >>$ >> in
- <:expr< let $biAnd_of_list bindings$ in $expr$ >>
-
- and create id ctyp =
+ let rec create id ctyp =
let _loc = loc_of_ctyp ctyp in
match ctyp with
| <:ctyp< unit >> -> <:expr< Rpc.Null >>
| <:ctyp< string >> -> <:expr< Rpc.String $id$ >>
| <:ctyp< bool >> -> <:expr< Rpc.Bool $id$ >>
- | <:ctyp< list (string * $t$) >> ->
- let nid, pid = new_id _loc in
- <:expr<
- let dict = List.map (fun (key, $pid$) -> (key, $create nid t$)) $id$ in
- Rpc.Dict dict >>
-
- | <:ctyp< list ($lid:key$ * $t$) >> when not (is_base key) ->
- let nid1, pid1 = new_id _loc in
- let nid2, pid2 = new_id _loc in
- <:expr<
- let is_a_real_dict = $is_string _loc key$ in
- let dict = List.map (fun ($pid1$, $pid2$) -> ($lid:rpc_of key$ $nid1$, $create nid2 t$)) $id$ in
- if is_a_real_dict then
- Rpc.Dict (List.map (fun [ (Rpc.String k, v) -> (k, v) | _ -> assert False ]) dict)
- else
- Rpc.Enum (List.map (fun (k, v) -> Rpc.Enum [k; v] ) dict) >>
-
- | <:ctyp< Hashtbl.t string $t$ >> ->
- let nid, pid = new_id _loc in
- <:expr<
- let dict = Hashtbl.fold (fun a $pid$ c -> [(a, $create nid t$)::c]) $id$ [] in
- Rpc.Dict dict >>
-
| <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
let ids, ctyps = decompose_variants _loc t in
let pattern (n, t) ctyps =
let ids, pids = new_id_list _loc ctyps in
- let body =
- if ids = [] then
- <:expr< Rpc.String $str:n$ >>
- else
- <:expr< Rpc.Enum [ Rpc.String $str:n$ :: $expr_list_of_list _loc (List.map2 create ids ctyps)$ ] >> in
+ let body = <:expr< Rpc.Enum [ Rpc.String $str:n$ :: $expr_list_of_list _loc (List.map2 create ids ctyps)$ ] >> in
<:match_case< $recompose_variant _loc (n,t) pids$ -> $body$ >> in
let patterns = mcOr_of_list (List.map2 pattern ids ctyps) in
<:expr< match $id$ with [ $patterns$ ] >>
let new_id, new_pid = new_id _loc in
<:expr< Rpc.Enum (Array.to_list (Array.map (fun $new_pid$ -> $create new_id t$) $id$)) >>
- | <:ctyp< { $t$ } >> -> product (fun field -> <:expr< $id$ . $lid:field$ >>) t
- | <:ctyp< < $t$ > >> -> product (fun field -> <:expr< $id$ # $lid:field$ >>) t
+ | <:ctyp< { $t$ } >> ->
+ let fields = decompose_fields _loc t in
+ let ids, pids = new_id_list _loc fields in
+ let bindings = List.map2 (fun pid (f, _) -> <:binding< $pid$ = $id$ . $lid:f$ >>) pids fields in
+ let one_expr nid (n, ctyp) = <:expr< ($str:n$, $create nid ctyp$) >> in
+ let expr = <:expr< Rpc.Dict $expr_list_of_list _loc (List.map2 one_expr ids fields)$ >> in
+ <:expr< let $biAnd_of_list bindings$ in $expr$ >>
+
+ | <:ctyp< < $t$ > >> ->
+ let fields = decompose_fields _loc t in
+ let ids, pids = new_id_list _loc fields in
+ let bindings = List.map2 (fun pid (f, _) -> <:binding< $pid$ = $id$ # $lid:f$ >>) pids fields in
+ let one_expr nid (n, ctyp) = <:expr< ($str:n$, $create nid ctyp$) >> in
+ let expr = <:expr< Rpc.Dict $expr_list_of_list _loc (List.map2 one_expr ids fields)$ >> in
+ <:expr< let $biAnd_of_list bindings$ in $expr$ >>
| <:ctyp< '$lid:a$ >> -> <:expr< $lid:rpc_of_polyvar a$ $id$ >>
let str_of_id id = match id with <:expr@loc< $lid:s$ >> -> <:expr@loc< $str:s$ >> | _ -> assert false
- let runtime_error name id expected =
+ let runtime_error id expected =
let _loc = Loc.ghost in
- <:match_case< __x__ -> do {
- if Rpc.get_debug () then
- Printf.eprintf "Runtime error in '%s_of_rpc:%s': got '%s' when '%s' was expected\\n" $str:name$ $str_of_id id$ (Rpc.to_string __x__) $str:expected$
- else ();
- raise (Rpc.Runtime_error ($str:expected$, __x__)) }
+ <:match_case< __x__ ->
+ failwith (Printf.sprintf "Runtime error while parsing '%s': got '%s' while '%s' was expected\\n" $str_of_id id$ (Rpc.to_string __x__) $str:expected$)
>>
- let runtime_exn_error name id doing =
+ let runtime_exn_error id doing =
let _loc = Loc.ghost in
- <:match_case< __x__ -> do {
- if Rpc.get_debug () then
- Printf.eprintf "Runtime error in '%s_of_rpc:%s': caught exception '%s' while doing '%s'\\n" $str:name$ $str_of_id id$ (Printexc.to_string __x__) $str:doing$
- else () ;
- raise (Rpc.Runtime_exception ($str:doing$, Printexc.to_string __x__)) } >>
-
- let product name build_one build_all id t =
- let _loc = loc_of_ctyp t in
- let nid, npid = new_id _loc in
- let fields = decompose_fields _loc t in
- let ids, pids = new_id_list _loc fields in
- let exprs = List.map2 (fun id (n, ctyp) -> build_one n id ctyp) ids fields in
- let bindings =
- List.map2 (fun pid (n, ctyp) ->
- if is_option ctyp then begin
- <:binding< $pid$ =
- if List.mem_assoc $str:n$ $nid$ then
- Rpc.Enum [List.assoc $str:n$ $nid$]
- else
- Rpc.Enum []
- >>
- end else
- <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error name nid ("Looking for key "^n)$ ] >>
- ) pids fields in
- <:expr< match $id$ with
- [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in $build_all exprs$ | $runtime_error name id "Dict"$ ]
+ <:match_case< __x__ ->
+ failwith (Printf.sprintf "Runtime error while parsing '%s': got exception '%s' while doing '%s'\\n" $str_of_id id$ (Printexc.to_string __x__) $str:doing$)
>>
- let rec create name id ctyp =
+ let rec create id ctyp =
let _loc = loc_of_ctyp ctyp in
match ctyp with
- | <:ctyp< unit >> -> <:expr< match $id$ with [ Rpc.Null -> () | $runtime_error name id "Null"$ ] >>
+ | <:ctyp< unit >> -> <:expr< match $id$ with [ Rpc.Null -> () | $runtime_error id "Null"$ ] >>
| <:ctyp< int >> ->
<:expr< match $id$ with [
Rpc.Int x -> Int64.to_int x
| Rpc.String s -> int_of_string s
- | $runtime_error name id "Int(int)"$ ] >>
+ | $runtime_error id "Int(int)"$ ] >>
| <:ctyp< int32 >> ->
<:expr< match $id$ with [
Rpc.Int x -> Int64.to_int32 x
| Rpc.String s -> Int32.of_string s
- | $runtime_error name id "Int(int32)"$ ] >>
+ | $runtime_error id "Int(int32)"$ ] >>
| <:ctyp< int64 >> ->
<:expr< match $id$ with [
Rpc.Int x -> x
| Rpc.String s -> Int64.of_string s
- | $runtime_error name id "Int(int64)"$ ] >>
+ | $runtime_error id "Int(int64)"$ ] >>
| <:ctyp< float >> ->
<:expr< match $id$ with [
Rpc.Float x -> x
| Rpc.String s -> float_of_string s
- | $runtime_error name id "Float"$ ] >>
+ | $runtime_error id "Float"$ ] >>
| <:ctyp< char >> ->
<:expr< match $id$ with [
Rpc.Int x -> Char.chr (Int64.to_int x)
| Rpc.String s -> Char.chr (int_of_string s)
- | $runtime_error name id "Int(char)"$ ] >>
+ | $runtime_error id "Int(char)"$ ] >>
- | <:ctyp< string >> -> <:expr< match $id$ with [ Rpc.String x -> x | $runtime_error name id "String(string)"$ ] >>
- | <:ctyp< bool >> -> <:expr< match $id$ with [ Rpc.Bool x -> x | $runtime_error name id "Bool"$ ] >>
-
- | <:ctyp< list (string * $t$ ) >> ->
- let nid, pid = new_id _loc in
- <:expr< match $id$ with [
- Rpc.Dict d -> List.map (fun (key, $pid$) -> (key, $create name nid t$)) d
- | $runtime_error name id "Dict"$ ] >>
-
- | <:ctyp< list ($lid:key$ * $t$) >> when not (is_base key) ->
- let nid, pid = new_id _loc in
- <:expr<
- let is_a_real_dict = $is_string _loc key$ in
- if is_a_real_dict then begin
- match $id$ with [
- Rpc.Dict d -> List.map (fun (key, $pid$) -> ($lid:of_rpc key$ (Rpc.String key), $create name nid t$)) d
- | $runtime_error name id "Dict"$ ]
- end else begin
- match $id$ with [
- Rpc.Enum e -> List.map (fun $pid$ -> $create name nid <:ctyp< ($lid:key$ * $t$) >>$) e
- | $runtime_error name id "Enum"$ ]
- end >>
-
- | <:ctyp< Hashtbl.t string $t$ >> ->
- let nid, pid = new_id _loc in
- <:expr< match $id$ with [
- Rpc.Dict d ->
- let h = Hashtbl.create (List.length d) in
- do { List.iter (fun (key,$pid$) -> Hashtbl.add h key $create name nid t$) d; h}
- | $runtime_error name id "Dict"$ ] >>
+ | <:ctyp< string >> -> <:expr< match $id$ with [ Rpc.String x -> x | $runtime_error id "String(string)"$ ] >>
+ | <:ctyp< bool >> -> <:expr< match $id$ with [ Rpc.Bool x -> x | $runtime_error id "Bool"$ ] >>
| <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
let ids, ctyps = decompose_variants _loc t in
let pattern (n, t) ctyps =
let ids, pids = new_id_list _loc ctyps in
- let patt =
- if ids = [] then
- <:patt< Rpc.String $str:n$ >>
- else
- <:patt< Rpc.Enum [ Rpc.String $str:n$ :: $patt_list_of_list _loc pids$ ] >> in
- let exprs = List.map2 (create name) ids ctyps in
+ let patt = <:patt< Rpc.Enum [ Rpc.String $str:n$ :: $patt_list_of_list _loc pids$ ] >> in
+ let exprs = List.map2 create ids ctyps in
let body = List.fold_right
(fun a b -> <:expr< $b$ $a$ >>)
(List.rev exprs)
(if t = `V then <:expr< $uid:n$ >> else <:expr< `$uid:n$ >>) in
<:match_case< $patt$ -> $body$ >> in
- let fail_match = <:match_case< $runtime_error name id "Enum[String s;...]"$ >> in
+ let fail_match = <:match_case< $runtime_error id "Enum[String s;...]"$ >> in
let patterns = mcOr_of_list (List.map2 pattern ids ctyps @ [ fail_match ]) in
<:expr< match $id$ with [ $patterns$ ] >>
| <:ctyp< option $t$ >> ->
let nid, npid = new_id _loc in
- <:expr< match $id$ with [ Rpc.Enum [] -> None | Rpc.Enum [ $npid$ ] -> Some $create name nid t$ | $runtime_error name id "Enum[]/Enum[_]"$ ] >>
+ <:expr< match $id$ with [ Rpc.Enum [] -> None | Rpc.Enum [ $npid$ ] -> Some $create nid t$ | $runtime_error id "Enum[]/Enum[_]"$ ] >>
| <:ctyp< $tup:tp$ >> ->
let ctyps = list_of_ctyp tp [] in
let ids, pids = new_id_list _loc ctyps in
- let exprs = List.map2 (create name) ids ctyps in
+ let exprs = List.map2 create ids ctyps in
<:expr< match $id$ with
- [ Rpc.Enum $patt_list_of_list _loc pids$ -> $expr_tuple_of_list _loc exprs$ | $runtime_error name id "List"$ ]
+ [ Rpc.Enum $patt_list_of_list _loc pids$ -> $expr_tuple_of_list _loc exprs$ | $runtime_error id "List"$ ]
>>
| <:ctyp< list $t$ >> ->
let nid, npid = new_id _loc in
let nid2, npid2 = new_id _loc in
<:expr< match $id$ with
- [ Rpc.Enum $npid$ -> List.map (fun $npid2$ -> $create name nid2 t$) $nid$ | $runtime_error name id "List"$ ]
+ [ Rpc.Enum $npid$ -> List.map (fun $npid2$ -> $create nid2 t$) $nid$ | $runtime_error id "List"$ ]
>>
| <:ctyp< array $t$ >> ->
let nid, npid = new_id _loc in
let nid2, npid2 = new_id _loc in
<:expr< match $id$ with
- [ Rpc.Enum $npid$ -> Array.of_list (List.map (fun $npid2$ -> $create name nid2 t$) $nid$) | $runtime_error name id "List"$ ]
+ [ Rpc.Enum $npid$ -> Array.of_list (List.map (fun $npid2$ -> $create nid2 t$) $nid$) | $runtime_error id "List"$ ]
>>
| <:ctyp< { $t$ } >> ->
- product name (fun n i ctyp -> <:rec_binding< $lid:n$ = $create name i ctyp$ >>) (fun es -> <:expr< { $rbSem_of_list es$ } >>) id t
+ let nid, npid = new_id _loc in
+ let fields = decompose_fields _loc t in
+ let ids, pids = new_id_list _loc fields in
+ let exprs = List.map2 (fun id (n, ctyp) -> <:rec_binding< $lid:n$ = $create id ctyp$ >>) ids fields in
+ let bindings =
+ List.map2 (fun pid (n, ctyp) ->
+ <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error nid ("Looking for key "^n)$ ] >>
+ ) pids fields in
+ <:expr< match $id$ with
+ [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in { $rbSem_of_list exprs$ } | $runtime_error id "Dict"$ ]
+ >>
| <:ctyp< < $t$ > >> ->
- product name (fun n i ctyp -> <:class_str_item< method $lid:n$ = $create name i ctyp$ >>) (fun es -> <:expr< object $crSem_of_list es$ end >>) id t
+ let nid, npid = new_id _loc in
+ let fields = decompose_fields _loc t in
+ let ids, pids = new_id_list _loc fields in
+ let exprs = List.map2 (fun id (n, ctyp) -> <:class_str_item< method $lid:n$ = $create id ctyp$ >>) ids fields in
+ let bindings =
+ List.map2 (fun pid (n, ctyp) ->
+ <:binding< $pid$ = try List.assoc $str:n$ $nid$ with [ $runtime_exn_error nid ("Looking for key "^n)$ ] >>
+ ) pids fields in
+ <:expr< match $id$ with
+ [ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in object $crSem_of_list exprs$ end | $runtime_error id "Dict"$ ]
+ >>
| <:ctyp< '$lid:a$ >> -> <:expr< $lid:of_rpc_polyvar a$ $id$ >>
| <:ctyp< $lid:t$ >> -> <:expr< $lid:of_rpc t$ $id$ >>
| <:ctyp< $id:m$ . $lid:t$ >> -> <:expr< $id:m$ . $lid:of_rpc t$ $id$ >>
- | <:ctyp< $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i (create name) id None t a
- | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i (create name) id (Some m) t a
+ | <:ctyp< $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i create id None t a
+ | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc of_rpc of_rpc_i create id (Some m) t a
| _ -> type_not_supported ctyp
<:binding< $lid:of_rpc name$ =
$List.fold_left
(fun accu arg -> <:expr< fun $lid:of_rpc_polyvar (name_of_polyvar _loc arg)$ -> $accu$ >>)
- (<:expr< fun $pid$ -> $create name id ctyp$ >>)
+ (<:expr< fun $pid$ -> $create id ctyp$ >>)
args$
>>
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
-(* -pp camlp4orf *)
open Camlp4
open PreCast
open Ast
-open Syntax
-(* utils *)
+open Pa_type_conv
-let biList_to_expr _loc bindings final =
- List.fold_right
- (fun b a -> <:expr< let $b$ in $a$ >>)
- bindings final
-
-let function_with_label_args _loc ~fun_name ~final_ident ~function_body ~return_type opt_args =
- let opt_args = opt_args @ [ <:patt< $lid:final_ident$ >> ] in
- <:binding< $lid:fun_name$ =
- $List.fold_right (fun b a ->
- <:expr<fun $b$ -> $a$ >>
- ) opt_args <:expr< ( $function_body$ : $return_type$ ) >>
- $ >>
-
-let rec list_of_fields _loc fields =
- match fields with
- | <:ctyp< $t1$; $t2$ >> ->
- list_of_fields _loc t1 @ list_of_fields _loc t2
- | <:ctyp< $lid:field_name$: mutable $t$ >> | <:ctyp< $lid:field_name$: $t$ >> ->
- [ field_name, t ]
- | _ -> failwith "unexpected type while processing fields"
-
-let record_of_fields _loc fields =
- let rec_bindings = List.map (fun (n,e) -> Ast.RbEq(_loc, <:ident< $lid:n$ >>, e)) fields in
- <:expr< { $rbSem_of_list rec_bindings$ } >>
-
-let list_of_expr _loc exprs =
- match List.rev exprs with
- | [] -> <:expr< [ ] >>
- | h::t -> List.fold_left (fun accu x -> <:expr< [ $x$ :: $accu$ ] >>) <:expr< [ $h$ ] >> t
-
-let patt_list_of_expr _loc patts =
- match List.rev patts with
- | [] -> assert false
- | h::t -> List.fold_left (fun accu x -> <:patt< [ $x$ :: $accu$ ] >>) <:patt< [ $h$ ] >> t
-
-let tuple_of_expr _loc exprs =
- match List.rev exprs with
- | [] -> assert false
- | h::t -> Ast.ExTup ( _loc, List.fold_left (fun accu x -> <:expr< $x$,$accu$ >>) h t)
-(* BUG? <:expr< ( $exCom_of_list exprs$ ) doesn't work >> *)
-
-let patt_tuple_of_expr _loc patts =
- Ast.PaTup (_loc, paCom_of_list patts)
-(* BUG? <:patt< ( $paCom_of_list patts$ ) doesn't work >> *)
-
-let decompose_variants _loc variant =
- let rec fn accu = function
- | <:ctyp< $t$ | $u$ >> -> fn (fn accu t) u
- | <:ctyp< $uid:id$ of $t$ >> -> (id, Some t) :: accu
- | <:ctyp< $uid:id$ >> -> (id, None) :: accu
- | _ -> failwith "decompose_variant"
- in fn [] variant
-
-let count = ref 0
-let new_id _loc =
- incr count;
- let new_id = Printf.sprintf "__x%i__" !count in
- <:expr< $lid:new_id$ >>, <:patt< $lid:new_id$ >>
-
-(* conversion ML type -> Rpc.Val.t *)
-module Rpc_of_ML = struct
-
- let rec value_of_ctyp _loc id = function
- | <:ctyp< unit >> -> <:expr< `None >>
- | <:ctyp< int >> -> <:expr< `Int (Int64.of_int $id$) >>
- | <:ctyp< int32 >> -> <:expr< `Int (Int64.of_int32 $id$) >>
- | <:ctyp< int64 >> -> <:expr< `Int $id$ >>
- | <:ctyp< float >> -> <:expr< `Float $id$ >>
- | <:ctyp< char >> -> <:expr< `String (Printf.sprintf "%c" $id$) >>
- | <:ctyp< string >> -> <:expr< `String $id$ >>
- | <:ctyp< bool >> -> <:expr< `Bool $id$ >>
-
- | <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
- let decomp = decompose_variants _loc t in
- let patterns =
- List.map (fun (n, t) ->
- let new_id, new_pid = new_id _loc in
- match t with
- | None ->
- <:match_case< $uid:n$ -> `List [ `String $str:n$ ] >>
- | Some t ->
- <:match_case< $uid:n$ $new_pid$ -> `List [ `String $str:n$; $value_of_ctyp _loc new_id t$ ] >>
- ) decomp in
- let pattern = mcOr_of_list patterns in
- <:expr< match $id$ with [ $pattern$ ] >>
-
- | <:ctyp< option $t$ >> ->
- let new_id, new_pid = new_id _loc in
- <:expr< match $id$ with [
- Some $new_pid$ -> `List [ $value_of_ctyp _loc new_id t$ ]
- | None -> `List []
- ] >>
-
- | <:ctyp< $tup:tp$ >> ->
- let tys = list_of_ctyp tp [] in
- let new_ids = List.map (fun t -> let new_id, new_pid = new_id _loc in (t,new_id, new_pid)) tys in
- let exprs = List.map (fun (t,new_id,_) -> value_of_ctyp _loc new_id t) new_ids in
- let new_ids_patt = List.map (fun (_,_,new_pid) -> new_pid) new_ids in
- <:expr<
- let $patt_tuple_of_expr _loc new_ids_patt$ = $id$ in
- `List $list_of_expr _loc exprs$
- >>
-
- | <:ctyp< list $t$ >> ->
- let new_id, new_pid = new_id _loc in
- <:expr< `List (List.map (fun $new_pid$ -> $value_of_ctyp _loc new_id t$) $id$) >>
-
- | <:ctyp< array $t$ >> ->
- let new_id, new_pid = new_id _loc in
- <:expr<
- `List (Array.to_list (Array.map (fun $new_pid$ -> $value_of_ctyp _loc new_id t$) $id$))
- >>
-
- | <:ctyp< { $t$ } >> ->
- let get_name_value (n,ctyp) = <:expr< ($str:n$, $value_of_ctyp _loc <:expr< $lid:n$ >> ctyp$) >> in
-
- let fields = list_of_fields _loc t in
- let bindings = List.map (fun (f,_) -> <:binding< $lid:f$ = $id$ . $lid:f$ >>) fields in
- let final_expr = <:expr< `Dict $list_of_expr _loc (List.map get_name_value fields)$ >> in
- biList_to_expr _loc bindings final_expr
-
- | <:ctyp< $lid:t$ >> -> <:expr< $lid:"rpc_of_"^t$ $id$ >>
-
- | _ -> failwith "Rpc_of_ML.value_of_ctyp: type not supported"
-
- let rpc_of _loc id ctyp =
- let id = <:expr< $lid:id$ >> in
- value_of_ctyp _loc id ctyp
-
- let process _loc id ctyp =
- function_with_label_args _loc
- ~fun_name:("rpc_of_"^id)
- ~final_ident:id
- ~function_body:(rpc_of _loc id ctyp)
- ~return_type:<:ctyp< Rpc.Val.t >>
- []
-
-end
-
-(* conversion Rpc.Val.t -> ML type *)
-module ML_of_rpc = struct
-
- let arg = let _loc = Loc.ghost in <:expr< $lid:"__x__"$ >>
- let parg = let _loc = Loc.ghost in <:patt< $lid:"__x__"$ >>
-
- let parse_error expected got =
- let _loc = Loc.ghost in
- <:expr< do {
- Printf.eprintf "Parse error: got '%s' while '%s' was expected.\n" (Rpc.Val.to_string $got$) $str:expected$;
- raise (Parse_error($str:expected$, $got$)) }
- >>
-
- let rec value_of_ctyp _loc id = function
- | <:ctyp< unit >> ->
- <:expr< match $id$ with [ `None -> () | $parg$ -> $parse_error "None" arg$ ] >>
-
- | <:ctyp< int >> ->
- <:expr< match $id$ with [ `Int x -> Int64.to_int x | $parg$ -> $parse_error "Int(int)" arg$ ] >>
-
- | <:ctyp< int32 >> ->
- <:expr< match $id$ with [ `Int x -> Int64.to_int32 x | $parg$ -> $parse_error "Int(int32)" arg$ ] >>
-
- | <:ctyp< int64 >> ->
- <:expr< match $id$ with [ `Int x -> x | $parg$ -> $parse_error "Int(int64)" arg$ ] >>
-
- | <:ctyp< float >> ->
- <:expr< match $id$ with [ `Float x -> x | $parg$ -> $parse_error "Float" arg$ ] >>
-
- | <:ctyp< char >> ->
- <:expr< match $id$ with [ `String x -> x.[0] | $parg$ -> $parse_error "String(char)" arg$ ] >>
-
- | <:ctyp< string >> ->
- <:expr< match $id$ with [ `String x -> x | $parg$ -> $parse_error "String(string)" arg$ ] >>
-
- | <:ctyp< bool >> ->
- <:expr< match $id$ with [ `Bool x -> x | $parg$ -> $parse_error "Bool" arg$ ] >>
-
- | <:ctyp< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
- let decomp = decompose_variants _loc t in
- let patterns =
- List.map (fun (n,t) ->
- let new_id, new_pid = new_id _loc in
- match t with
- | None ->
- <:match_case< `List [ `String $str:n$ ] -> $uid:n$ >>
- | Some t ->
- <:match_case< `List [ `String $str:n$; $new_pid$ ] -> $uid:n$ $value_of_ctyp _loc new_id t$ >>
- ) decomp
- @ [ <:match_case< $parg$ -> $parse_error "List[String;_]" arg$ >> ] in
- let pattern = mcOr_of_list patterns in
- <:expr< match $id$ with [ $pattern$ ] >>
-
- | <:ctyp< option $t$ >> ->
- let new_id, new_pid = new_id _loc in
- <:expr< match $id$ with [
- `List [] -> None
- | `List [$new_pid$] -> Some $value_of_ctyp _loc new_id t$
- | $parg$ -> $parse_error "List[_]" arg$
- ] >>
-
- | <:ctyp< $tup:tp$ >> ->
- let tys = list_of_ctyp tp [] in
- let new_ids = List.map (fun t -> let new_id, new_pid = new_id _loc in (t,new_id,new_pid)) tys in
- let exprs = List.map (fun (t,new_id,mew_pid) -> value_of_ctyp _loc new_id t) new_ids in
- let new_ids_patt = List.map (fun (_,_,new_pid) -> new_pid) new_ids in
- let new_id, new_pid = new_id _loc in
- <:expr< match $id$ with [
- `List $new_pid$ ->
- match $new_id$ with [
- $patt_list_of_expr _loc new_ids_patt$ -> $tuple_of_expr _loc exprs$
- | $parg$ -> $parse_error (Printf.sprintf "list of size %i" (List.length tys)) <:expr< `List $arg$ >>$ ]
- | $parg$ -> $parse_error "List[_]" arg$
- ] >>
-
- | <:ctyp< list $t$ >> ->
- let new_id, new_pid = new_id _loc in
- <:expr< match $id$ with [
- `List $new_pid$ ->
- let __fn__ $parg$ = $value_of_ctyp _loc arg t$ in
- List.map __fn__ $new_id$
- | $parg$ -> $parse_error "List[_]" arg$
- ] >>
-
- | <:ctyp< array $t$ >> ->
- let new_id, new_pid = new_id _loc in
- <:expr< match $id$ with [
- `List $new_pid$ ->
- let __fn__ $parg$ = $value_of_ctyp _loc arg t$ in
- Array.of_list (List.map __fn__ $new_id$)
- | $parg$ -> $parse_error "List[_]" arg$
- ] >>
-
- | <:ctyp< { $t$ } >> ->
- let new_id, new_pid = new_id _loc in
- let fields = list_of_fields _loc t in
- let bindings =
- List.map (fun (n,ctyp) ->
- <:binding< $lid:n$ =
- let __f__ $parg$ = $value_of_ctyp _loc arg ctyp$ in
- __f__ (try List.assoc $str:n$ $new_id$ with [ Not_found -> $parse_error ("key "^n) id$ ])
- >>)
- fields in
- let record_bindings = List.map (fun (n,_) -> (n,<:expr< $lid:n$ >>)) fields in
- let final_expr = record_of_fields _loc record_bindings in
- <:expr< match $id$ with [
- `Dict $new_pid$ -> $biList_to_expr _loc bindings final_expr$
- | $parg$ -> $parse_error "Dict(_)" arg$
- ] >>
-
- | <:ctyp< $lid:t$ >> -> <:expr< $lid:t^"_of_rpc"$ $id$ >>
-
- | _ -> failwith "ML_of_rpc.scalar_of_ctyp: unsuported type"
-
- let of_rpc _loc id ctyp =
- let id = <:expr< $lid:id$ >> in
- value_of_ctyp _loc id ctyp
-
- let process _loc id ctyp =
- function_with_label_args _loc
- ~fun_name:(id^"_of_rpc")
- ~final_ident:id
- ~function_body:(of_rpc _loc id ctyp)
- ~return_type:<:ctyp< $lid:id$ >>
- []
-
-end
-
-let process_type_declaration _loc process ctyp =
- let rec fn ty accu = match ty with
- | Ast.TyAnd (_loc, tyl, tyr) -> fn tyl (fn tyr accu)
- | Ast.TyDcl (_loc, id, _, ty, []) -> process _loc id ty :: accu
- | _ -> accu in
- biAnd_of_list (fn ctyp [])
-
-let () =
- Pa_type_conv.add_generator "rpc"
- (fun ctyp ->
- let _loc = loc_of_ctyp ctyp in
- <:str_item<
- exception Parse_error of (string * Rpc.Val.t);
- value rec $process_type_declaration _loc Rpc_of_ML.process ctyp$;
- value rec $process_type_declaration _loc ML_of_rpc.process ctyp$
- >>)
+let _ =
+ add_generator "rpc" (fun tds ->
+ let _loc = loc_of_ctyp tds in
+ <:str_item< $P4_rpc.gen tds$ >>)
* GNU Lesser General Public License for more details.
*)
-module Sig = struct
- type t =
- [ `Int | `Bool | `Float | `String
- | `Product of t list
- | `Named_product of (string * t) list
- | `Named_sum of (string * t) list
- | `Option of t ]
-end
-
-module Val = struct
- type t =
- [ `Int of int64
- | `Bool of bool
- | `Float of float
- | `String of string
- | `List of t list
- | `Dict of (string * t) list
- | `None ]
-
- let rec to_string (x:t) = match x with
- | `Int i -> Printf.sprintf "Int(%Lu)" i
- | `Bool b -> Printf.sprintf "Bool(%b)" b
- | `Float f -> Printf.sprintf "Float(%f)" f
- | `String s -> Printf.sprintf "String(%s)" s
- | `List l -> "List [ " ^ String.concat ", " (List.map to_string l) ^ " ]"
- | `Dict d -> "Dict {" ^ String.concat ", " (List.map (fun (s,t) -> Printf.sprintf "%s: %s" s (to_string t)) d) ^ " }"
- | `None -> "None"
-end
-
-(* The first argument is the list of record field names we already went trough *)
-type callback = string list -> Val.t -> unit
+type t =
+ | Int of int64
+ | Bool of bool
+ | Float of float
+ | String of string
+ | Enum of t list
+ | Dict of (string * t) list
+ | Null
+
+open Printf
+let map_strings sep fn l = String.concat sep (List.map fn l)
+let rec to_string t = match t with
+ | Int i -> sprintf "I(%Li)" i
+ | Bool b -> sprintf "B(%b)" b
+ | Float f -> sprintf "F(%g)" f
+ | String s -> sprintf "S(%s)" s
+ | Enum ts -> sprintf "[%s]" (map_strings ";" to_string ts)
+ | Dict ts -> sprintf "{%s}" (map_strings ";" (fun (s,t) -> sprintf "%s:%s" s (to_string t)) ts)
+ | Null -> "N"
+
+
+let rpc_of_t x = x
+let rpc_of_int64 i = Int i
+let rpc_of_bool b = Bool b
+let rpc_of_float f = Float f
+let rpc_of_string s = String s
+
+let t_of_rpc x = x
+let int64_of_rpc = function Int i -> i | _ -> failwith "int64_of_rpc"
+let bool_of_rpc = function Bool b -> b | _ -> failwith "bool_of_rpc"
+let float_of_rpc = function Float f -> f | _ -> failwith "float_of_rpc"
+let string_of_rpc = function String s -> s | _ -> failwith "string_of_rpc"
+
+type callback = string list -> t -> unit
type call = {
name: string;
- params: Val.t list
+ params: t list;
}
+let call name params = { name = name; params = params }
+
type response = {
success: bool;
- contents: Val.t
+ contents: t;
}
+
+let success v = { success = true; contents = v }
+let failure v = { success = false; contents = v }
val int64_of_rpc : t -> int64
val rpc_of_int64 : int64 -> t
-val int32_of_rpc : t -> int32
-val rpc_of_int32 : int32 -> t
-
-val int_of_rpc : t -> int
-val rpc_of_int : int -> t
-
val bool_of_rpc : t -> bool
val rpc_of_bool : bool -> t
val t_of_rpc : t -> t
val rpc_of_t : t -> t
-val unit_of_rpc : t -> unit
-val rpc_of_unit : unit -> t
-
(** {2 Calls} *)
type callback = string list -> t -> unit
val call : string -> t list -> call
-val string_of_call : call -> string
-
(** {2 Responses} *)
type response = { success : bool; contents : t }
-val string_of_response : response -> string
-
val success : t -> response
val failure : t -> response
-
-(** {2 Run-time errors} *)
-
-exception Runtime_error of string * t
-exception Runtime_exception of string * string
-
-(** {2 Debug options} *)
-val set_debug : bool -> unit
-val get_debug : unit -> bool
*)
open Printf
+open Rpc
let debug = ref false
let debug (fmt: ('a, unit, string, unit) format4) : 'a =
s
let rec add_value f = function
- | `Int i ->
- f "<value><i4>";
+ | Null ->
+ f "<value><nil/></value>"
+
+ | Int i ->
+ f "<value>";
f (Int64.to_string i);
- f "</i4></value>"
+ f "</value>"
- | `Bool b ->
- f "<value><bool>";
- f (string_of_bool b);
- f "</bool></value>"
+ | Bool b ->
+ f "<value><boolean>";
+ f (if b then "1" else "0");
+ f "</boolean></value>"
- | `Float d ->
+ | Float d ->
f "<value><double>";
- f (string_of_float d);
+ f (Printf.sprintf "%g" d);
f "</double></value>"
- | `String s ->
- f "<value><string>";
+ | String s ->
+ f "<value>";
f (check s);
- f "</string></value>"
+ f "</value>"
- | `List a ->
+ | Enum l ->
f "<value><array><data>";
- List.iter (add_value f) a;
+ List.iter (add_value f) l;
f "</data></array></value>"
- | `Dict s ->
+ | Dict d ->
let add_member (name, value) =
f "<member><name>";
f name;
f "</member>"
in
f "<value><struct>";
- List.iter add_member s;
+ List.iter add_member d;
f "</struct></value>"
- | `None ->
- f "<value><string>nil</string></value>"
-
let to_string x =
let buf = Buffer.create 128 in
add_value (Buffer.add_string buf) x;
let add = B.add_string buf in
add "<?xml version=\"1.0\"?>";
add "<methodCall><methodName>";
- add (check call.Rpc.name);
+ add (check call.name);
add "</methodName><params>";
List.iter (fun p ->
add "<param>";
add (to_string p);
add "</param>"
- ) call.Rpc.params;
+ ) call.params;
add "</params></methodCall>";
B.contents buf
let module B = Buffer in
let buf = B.create 256 in
let add = B.add_string buf in
- let v = `Dict [ (if response.Rpc.success then "success" else "failure"), response.Rpc.contents ] in
+ let v = if response.success then response.contents else Dict [ "failure", response.contents ] in
add "<?xml version=\"1.0\"?><methodResponse><params><param>";
add (to_string v);
add "</param></params></methodResponse>";
| `El_end ->
begin match tags with
| [] ->
- Buffer.add_string buf "</>";
+ Buffer.add_string buf "<?/>";
aux tags
| h :: t ->
Buffer.add_string buf "</";
module Parser = struct
- (* Specific helpers *)
+ (* Helpers *)
let get_data input =
match Xmlm.input input with
| `Data d -> d
List.rev !r
- (* Basic constructors *)
- let make_int ?callback accu data : Rpc.Val.t =
- let r = `Int (Int64.of_string data) in
- match callback with
- | Some f -> f (List.rev accu) r; r
- | None -> r
-
- let make_bool ?callback accu data : Rpc.Val.t =
- let r = `Bool (bool_of_string data) in
+ (* Constructors *)
+ let make fn ?callback accu data =
+ let r = fn data in
match callback with
| Some f -> f (List.rev accu) r; r
| None -> r
- let make_double ?callback accu data : Rpc.Val.t =
- let r = `Float (float_of_string data) in
- match callback with
- | Some f -> f (List.rev accu) r; r
- | None -> r
-
- let make_string ?callback accu data : Rpc.Val.t =
- let r = match data with
- | "nil" -> `None
- | s -> `String s in
- match callback with
- | Some f -> f (List.rev accu) r; r
- | None -> r
-
- let make_array ?callback accu data : Rpc.Val.t =
- let r = `List data in
- match callback with
- | Some f -> f (List.rev accu) r; r
- | None -> r
-
- let make_struct ?callback accu data : Rpc.Val.t =
- let r = `Dict data in
- match callback with
- | Some f -> f (List.rev accu) r; r
- | None -> r
+ let make_null = make (fun () -> Null)
+ let make_int = make (fun data -> Int (Int64.of_string data))
+ let make_bool = make (fun data -> Bool (if data = "1" then true else false))
+ let make_float = make (fun data -> Float (float_of_string data))
+ let make_string = make (fun data -> String data)
+ let make_enum = make (fun data -> Enum data)
+ let make_dict = make (fun data -> Dict data)
(* General parser functions *)
let rec of_xml ?callback accu input =
| e -> Printf.eprintf "%s\n%!" (Printexc.to_string e); exit (-1)
and basic_types ?callback accu input = function
- | "int" | "i4" -> make_int ?callback accu (get_data input)
- | "bool" -> make_bool ?callback accu (get_data input)
- | "double" -> make_double ?callback accu (get_data input)
- | "string" -> make_string ?callback accu (get_data input)
- | "array" -> make_array ?callback accu (data (of_xmls ?callback accu) input)
- | "struct" -> make_struct ?callback accu (members (fun name -> of_xml ?callback (name::accu)) input)
- | e -> make_string ?callback accu e
+ | "int"
+ | "i4" -> make_int ?callback accu (get_data input)
+ | "boolean" -> make_bool ?callback accu (get_data input)
+ | "double" -> make_float ?callback accu (get_data input)
+ | "string" -> make_string ?callback accu (get_data input)
+ | "array" -> make_enum ?callback accu (data (of_xmls ?callback accu) input)
+ | "struct" -> make_dict ?callback accu (members (fun name -> of_xml ?callback (name::accu)) input)
+ | "nil" -> make_null ?callback accu ()
+ | tag -> parse_error tag (Xmlm.peek input) input
and of_xmls ?callback accu input =
let r = ref [] in
done;
) input
) input;
- { Rpc.name = !name; Rpc.params = !params }
+ call !name (List.rev !params)
let response_of_string ?callback str =
let input = Xmlm.make_input (`String (0, str)) in
Parser.map_tag "methodResponse" (fun input ->
Parser.map_tag "params" (fun input ->
Parser.map_tag "param" (fun input ->
- let signal = Xmlm.peek input in
match Parser.of_xml ?callback [] input with
- | `Dict [ "success", v ] -> { Rpc.success = true; Rpc.contents = v }
- | `Dict [ "failure", v ] -> { Rpc.success = false; Rpc.contents = v }
- | v -> parse_error "response" signal input
+ | Dict [ "failure", v ] -> failure v
+ | v -> success v
) input
) input
) input
* GNU Lesser General Public License for more details.
*)
-val to_string : Rpc.Val.t -> string
-val of_string : ?callback:Rpc.callback -> string -> Rpc.Val.t
+val to_string : Rpc.t -> string
+val of_string : ?callback:Rpc.callback -> string -> Rpc.t
val string_of_call: Rpc.call -> string
val call_of_string: ?callback:Rpc.callback -> string -> Rpc.call
version = "@VERSION@"
description = "Stdext - Common stdlib extensions"
-requires = "unix,uuid,bigarray,rpc-light,jsonrpc"
+requires = "unix,uuid,bigarray,rpc-light.json"
archive(byte) = "stdext.cma"
archive(native) = "stdext.cmxa"
projects / xcp / xen-api-libs.git / commitdiff