[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Xen-API] [PATCH 02 of 17] [rpc-light] Backport the value library and clean-up the Makefile and the library building



# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
# Date 1262958466 0
# Node ID 383e08728219228b6818b5f5274202e96c89786e
# Parent  5158e68dfc6b17a197655390b0301bfd6fa603ea
[rpc-light] Backport the value library and clean-up the Makefile and the 
library building.

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@xxxxxxxxxx>

diff -r 5158e68dfc6b -r 383e08728219 forking_executioner/Makefile
--- a/forking_executioner/Makefile      Fri Jan 08 13:47:46 2010 +0000
+++ b/forking_executioner/Makefile      Fri Jan 08 13:47:46 2010 +0000
@@ -31,10 +31,10 @@
 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 $@  $<
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/META
--- /dev/null   Thu Jan 01 00:00:00 1970 +0000
+++ b/rpc-light/META    Fri Jan 08 13:47:46 2010 +0000
@@ -0,0 +1,34 @@
+version = "0.2"
+description = "RPC light: lightweight library to convert plain ML types to and 
from RPC values"
+requires = "rpc-light.xml, rpc-light.json"
+
+package "syntax" (
+  version = "0.1"
+  description = "rpc-light: library to marshalling/unmarshalling ML types 
to/from RPC intermediate language"
+  requires = "type-conv.syntax"
+  archive(syntax,preprocessor) = "pa_rpc.cma"
+  archive(syntax,toploop) = "pa_rpc.cma"
+  )
+
+package "core" (
+  version = "0.1"
+  description = "Common RPC definitions"
+  archive(byte) = "rpc.cmo"
+  archive(native) = "rpc.cmx"
+)
+
+package "xml" (
+  version = "0.1"
+  description = "XML-RPC marshalling/unmarshalling"
+  requires = "rpc-light.core,xmlm"
+  archive(byte) = "xmlrpc.cmo"
+  archive(native) = "xmlrpc.cmx"
+  )
+
+package "json" (
+  version = "0.1"
+  description = "JSON-RPC marshalling/unmarshalling"
+  requires = "rpc-light.core"
+  archive(byte) = "jsonrpc.cmo"
+  archive(native) = "jsonrpc.cmx"
+)
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/META-jsonrpc
--- a/rpc-light/META-jsonrpc    Fri Jan 08 13:47:46 2010 +0000
+++ /dev/null   Thu Jan 01 00:00:00 1970 +0000
@@ -1,4 +0,0 @@
-version = "0.1"
-description = "JSON-RPC marshalling/unmarshalling"
-archive(byte) = "jsonrpc.cma"
-archive(native) = "jsonrpc.cmxa"
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/META-rpc-light
--- a/rpc-light/META-rpc-light  Fri Jan 08 13:47:46 2010 +0000
+++ /dev/null   Thu Jan 01 00:00:00 1970 +0000
@@ -1,11 +0,0 @@
-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
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/META-xmlrpc
--- a/rpc-light/META-xmlrpc     Fri Jan 08 13:47:46 2010 +0000
+++ /dev/null   Thu Jan 01 00:00:00 1970 +0000
@@ -1,5 +0,0 @@
-version = "0.1"
-description = "XML-RPC marshalling/unmarshalling"
-requires = "xmlm"
-archive(byte) = "xmlrpc.cma"
-archive(native) = "xmlrpc.cmxa"
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/Makefile
--- a/rpc-light/Makefile        Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/Makefile        Fri Jan 08 13:47:46 2010 +0000
@@ -3,79 +3,47 @@
 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
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/examples/Makefile
--- a/rpc-light/examples/Makefile       Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/examples/Makefile       Fri Jan 08 13:47:46 2010 +0000
@@ -2,7 +2,7 @@
 OCAMLOPT = ocamlfind ocamlopt
 OCAMLFLAGS = -annot -g
 
-PACKS = xmlrpc,jsonrpc
+PACKS = rpc-light
 EXAMPLES = all_types
 
 EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/examples/all_types.ml
--- a/rpc-light/examples/all_types.ml   Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/examples/all_types.ml   Fri Jan 08 13:47:46 2010 +0000
@@ -14,8 +14,12 @@
 
 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;
@@ -24,67 +28,75 @@
        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
 
-       Printf.printf "xmlrpc: %s\n\n" xml;
-       Printf.printf "jsonrpc: %s\n\n" json;
+       let rpc_xml = Xmlrpc.to_string rpc in
+       let rpc_json = Jsonrpc.to_string rpc in
+
+       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);
        
-       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
+       (* Testing calls and responses *)
+       
+       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)
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/jsonrpc.ml
--- a/rpc-light/jsonrpc.ml      Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/jsonrpc.ml      Fri Jan 08 13:47:46 2010 +0000
@@ -43,18 +43,18 @@
 
 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 "}"
 
@@ -71,26 +71,26 @@
        (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
 
@@ -122,13 +122,13 @@
                | 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;
@@ -224,7 +224,7 @@
        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, _ ->
@@ -238,8 +238,8 @@
 
        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"
 
@@ -258,7 +258,7 @@
                        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
@@ -268,14 +268,14 @@
                       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
@@ -283,7 +283,7 @@
                        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 ->
@@ -315,14 +315,14 @@
                        (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 ->
@@ -330,7 +330,7 @@
                        | '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 ->
@@ -367,7 +367,7 @@
                | 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")
                        
@@ -396,7 +396,7 @@
                | 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")
 
@@ -431,7 +431,7 @@
                | 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 =
@@ -497,24 +497,24 @@
 
 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)
 
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/jsonrpc.mli
--- a/rpc-light/jsonrpc.mli     Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/jsonrpc.mli     Fri Jan 08 13:47:46 2010 +0000
@@ -12,8 +12,8 @@
  * 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
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/p4_rpc.ml
--- /dev/null   Thu Jan 01 00:00:00 1970 +0000
+++ b/rpc-light/p4_rpc.ml       Fri Jan 08 13:47:46 2010 +0000
@@ -0,0 +1,369 @@
+(*
+ * Copyright (c) 2009 Thomas Gazagnaire <thomas@xxxxxxxxxxxxxx>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+open Camlp4
+open PreCast
+open Ast
+open Syntax
+
+let rpc_of n = "rpc_of_" ^ n
+let of_rpc n = n ^ "_of_rpc"
+
+let rpc_of_polyvar a = "__rpc_of_" ^ a ^ "__"
+let of_rpc_polyvar a = "__" ^ a ^ "_of_rpc__"
+
+let rpc_of_i i = "__rpc_of_" ^ string_of_int i ^ "__"
+let of_rpc_i i = "__" ^ string_of_int i ^ "_of_rpc__"
+
+(* Utils *)
+
+let list_foldi f step0 l =
+       fst (List.fold_left (fun (accu, i) x -> f accu x i, i+1) (step0, 0) l)
+
+let list_of_ctyp_decl tds =
+       let rec aux accu = function
+       | Ast.TyAnd (loc, tyl, tyr)      -> aux (aux accu tyl) tyr
+       | Ast.TyDcl (loc, id, args, ty, []) -> (id, args, ty) :: accu
+       | _                               ->  failwith "list_of_ctyp_decl: 
unexpected type"
+       in aux [] tds
+
+let rec decompose_fields _loc fields =
+       match fields with
+       | <:ctyp< $t1$; $t2$ >> ->
+               decompose_fields _loc t1 @ decompose_fields _loc t2
+       | <:ctyp< $lid:field_name$: mutable $t$ >> | <:ctyp< $lid:field_name$: 
$t$ >> ->
+               [ field_name, t ]
+       | _ -> failwith "unexpected type while processing fields"
+
+let expr_list_of_list _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_list _loc patts =
+       match List.rev patts with
+       | []   -> <:patt< [] >>
+       | h::t -> List.fold_left (fun accu x -> <:patt< [ $x$ :: $accu$ ] >>) 
<:patt< [ $h$ ] >> t
+
+let expr_tuple_of_list _loc = function
+       | []   -> <:expr< >>
+       | [x]  -> x
+       | h::t -> ExTup (_loc, List.fold_left (fun accu n -> <:expr< $accu$, 
$n$ >>) h t)
+
+let patt_tuple_of_list _loc = function
+       | []   -> <:patt< >>
+       | [x]  -> x
+       | h::t -> PaTup (_loc, List.fold_left (fun accu n -> <:patt< $accu$, 
$n$ >>) h t)
+
+let name_of_polyvar _loc = function
+       | <:ctyp< '$lid:a$ >> -> a
+       | _ -> failwith "name_of_polyvar"
+
+let rec decompose_args _loc = function
+       | <:ctyp< $x$ $y$ >> -> decompose_args _loc x @ decompose_args _loc y
+       | <:ctyp< $x$     >> -> [x]
+
+let decompose_variants _loc variant =
+       let rec fn accu = function
+       | <:ctyp< $t$ | $u$ >>        -> fn (fn accu t) u
+       | <:ctyp< $uid:id$ of $t$ >>  -> ((id, `V) , list_of_ctyp t []) :: accu
+       | <:ctyp< `$uid:id$ of $t$ >> -> ((id, `PV), list_of_ctyp t []) :: accu
+       | <:ctyp< $uid:id$ >>         -> ((id, `V) , []) :: accu
+       | <:ctyp< `$uid:id$ >>        -> ((id, `PV), []) :: accu
+       | _ -> failwith "decompose_variant"
+       in
+       List.split (fn [] variant)
+
+let recompose_variant _loc (n, t) patts =
+       match t, patts with
+       | `V , [] -> <:patt< $uid:n$ >>
+       | `PV, [] -> <:patt< `$uid:n$ >>
+       | `V , _  -> <:patt< $uid:n$ $patt_tuple_of_list _loc patts$ >>
+       | `PV, _  -> <:patt< `$uid:n$ $patt_tuple_of_list _loc patts$ >>
+
+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$ >>
+
+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"
+
+let apply _loc fn fn_i create id modules t a =
+       let args = decompose_args _loc a in
+       let app expr = list_foldi (fun accu _ i -> <:expr< $accu$ $lid:fn_i i$ 
>>) expr args in
+       let expr = match modules with
+               | None    -> <:expr< $app <:expr< $lid:fn t$ >>$ $id$ >>
+               | Some ms -> <:expr< $app <:expr< $id:ms$ . $lid:fn t$ >>$ $id$ 
>> in
+       list_foldi
+               (fun accu arg i ->
+                        let id, pid = new_id _loc in
+                        <:expr< let $lid:fn_i i$ = fun $pid$ -> $create id 
arg$ in $accu$ >>)
+               expr
+               args
+
+(* Conversion ML type -> Rpc.value *)
+module Rpc_of = struct
+       
+       let rec create id ctyp =
+               let _loc = loc_of_ctyp ctyp in
+               match ctyp with
+               | <:ctyp< unit >>    -> <:expr< Rpc.Null >>
+               | <:ctyp< int >>     -> <:expr< Rpc.Int (Int64.of_int $id$) >>
+               | <:ctyp< int32 >>   -> <:expr< Rpc.Int (Int64.of_int32 $id$) >>
+               | <:ctyp< int64 >>   -> <:expr< Rpc.Int $id$ >>
+               | <:ctyp< float >>   -> <:expr< Rpc.Float $id$ >>
+               | <:ctyp< char >>    -> <:expr< Rpc.Int (Int64.of_int 
(Char.code $id$)) >>
+               | <:ctyp< string >>  -> <:expr< Rpc.String $id$ >>
+               | <:ctyp< bool >>    -> <:expr< Rpc.Bool $id$ >>
+
+               | <: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 = <: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$ ] >>
+
+               | <:ctyp< option $t$ >> ->
+                       let new_id, new_pid = new_id _loc in
+                       <:expr< match $id$ with [ Some $new_pid$ -> Rpc.Enum [ 
$create new_id t$ ] | None -> Rpc.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 ids ctyps in
+                       <:expr<
+                               let $patt_tuple_of_list _loc pids$ = $id$ in
+                               Rpc.Enum $expr_list_of_list _loc exprs$
+                       >>
+
+               | <:ctyp< list $t$ >> ->
+                       let new_id, new_pid = new_id _loc in
+                       <:expr< Rpc.Enum (List.map (fun $new_pid$ -> $create 
new_id t$) $id$) >>
+
+               | <:ctyp< array $t$ >> ->
+                       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$ } >> ->
+                       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$  >>
+
+               | <:ctyp< $lid:t$ >>              -> <:expr< $lid:rpc_of t$ 
$id$  >>
+               | <:ctyp< $id:m$ . $lid:t$ >>     -> <:expr< $id:m$ . 
$lid:rpc_of t$ $id$  >>
+
+               | <:ctyp< $lid:t$ $a$ >>          -> apply _loc rpc_of rpc_of_i 
create id None t a
+               | <:ctyp< $id:m$ . $lid:t$ $a$ >> -> apply _loc rpc_of rpc_of_i 
create id (Some m) t a
+
+               | _ -> type_not_supported ctyp
+
+       let gen_one (name, args, ctyp) =
+               let _loc = loc_of_ctyp ctyp in
+               let id, pid = new_id _loc in
+               <:binding< $lid:rpc_of name$ =
+                       $List.fold_left
+                               (fun accu arg -> <:expr< fun 
$lid:rpc_of_polyvar (name_of_polyvar _loc arg)$ -> $accu$ >>)
+                               (<:expr< fun $pid$ -> $create id ctyp$ >>)
+                               args$
+               >>
+
+       let gen tds =
+               let _loc = loc_of_ctyp tds in
+               let bindings = List.map gen_one (list_of_ctyp_decl tds) in
+               biAnd_of_list bindings
+end
+
+
+(* Conversion Rpc.value -> ML type *)
+module Of_rpc = struct
+
+       let str_of_id id = match id with <:expr@loc< $lid:s$ >> -> <:expr@loc< 
$str:s$ >> | _ -> assert false
+
+       let runtime_error id expected =
+               let _loc = Loc.ghost in
+               <: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 id doing =
+               let _loc = Loc.ghost in
+               <: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 id ctyp =
+               let _loc = loc_of_ctyp ctyp in
+               match ctyp with
+               | <: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 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 id "Int(int32)"$ ] >>
+
+               | <:ctyp< int64 >>  ->
+                       <:expr< match $id$ with [
+                         Rpc.Int x    -> x
+                       | Rpc.String s -> Int64.of_string s
+                       | $runtime_error id "Int(int64)"$ ] >>
+
+               | <:ctyp< float >>  ->
+                       <:expr< match $id$ with [
+                         Rpc.Float x  -> x
+                       | Rpc.String s -> float_of_string s
+                       | $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 id "Int(char)"$ ] >>
+
+               | <: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 = <: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 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 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 ids ctyps in
+                       <:expr< match $id$ with
+                               [ 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 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 nid2 t$) $nid$) | $runtime_error id "List"$ ]
+                       >>
+
+               | <:ctyp< { $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$ > >> ->
+                       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 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
+
+       let gen_one (name, args, ctyp) =
+               let _loc = loc_of_ctyp ctyp in
+               let id, pid = new_id _loc in
+               <: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 id ctyp$ >>)
+                               args$
+               >>
+
+       let gen tds =
+               let _loc = loc_of_ctyp tds in
+               let bindings = List.map gen_one (list_of_ctyp_decl tds) in
+               biAnd_of_list bindings
+end
+
+
+let gen tds =
+       let _loc = loc_of_ctyp tds in
+       <:str_item<
+               value rec $Of_rpc.gen tds$;
+               value rec $Rpc_of.gen tds$;
+       >>
+
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/pa_rpc.ml
--- a/rpc-light/pa_rpc.ml       Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/pa_rpc.ml       Fri Jan 08 13:47:46 2010 +0000
@@ -11,295 +11,14 @@
  * 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$ >>)
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/rpc.ml
--- a/rpc-light/rpc.ml  Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/rpc.ml  Fri Jan 08 13:47:46 2010 +0000
@@ -12,44 +12,52 @@
  * 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
+type t =
+       | Int of int64
+       | Bool of bool
+       | Float of float
+       | String of string
+       | Enum of t list
+       | Dict of (string * t) list
+       | Null
 
-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 ]
+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 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
+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 }
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/rpc.mli
--- /dev/null   Thu Jan 01 00:00:00 1970 +0000
+++ b/rpc-light/rpc.mli Fri Jan 08 13:47:46 2010 +0000
@@ -0,0 +1,58 @@
+(*
+ * Copyright (C) 2006-2009 Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** {2 Value} *)
+
+type t =
+    Int of int64
+  | Bool of bool
+  | Float of float
+  | String of string
+  | Enum of t list
+  | Dict of (string * t) list
+  | Null
+
+val to_string : t -> string
+
+(** {2 Basic constructors} *)
+
+val int64_of_rpc : t -> int64
+val rpc_of_int64 : int64 -> t
+
+val bool_of_rpc : t -> bool
+val rpc_of_bool : bool -> t
+
+val float_of_rpc : t -> float
+val rpc_of_float : float -> t
+
+val string_of_rpc : t -> string
+val rpc_of_string : string -> t
+
+val t_of_rpc : t -> t
+val rpc_of_t : t -> t
+
+(** {2 Calls} *)
+
+type callback = string list -> t -> unit
+
+type call = { name : string; params : t list }
+
+val call : string -> t list -> call
+
+(** {2 Responses} *)
+
+type response = { success : bool; contents : t }
+
+val success : t -> response
+val failure : t -> response
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/xmlrpc.ml
--- a/rpc-light/xmlrpc.ml       Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/xmlrpc.ml       Fri Jan 08 13:47:46 2010 +0000
@@ -13,6 +13,7 @@
  *)
 
 open Printf
+open Rpc
 
 let debug = ref false
 let debug (fmt: ('a, unit, string, unit) format4) : 'a =
@@ -31,32 +32,35 @@
        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;
@@ -65,11 +69,8 @@
                        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
@@ -82,13 +83,13 @@
        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
 
@@ -96,7 +97,7 @@
        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>";
@@ -123,7 +124,7 @@
                        | `El_end ->
                                begin match tags with
                                | []     ->
-                                       Buffer.add_string buf "</>";
+                                       Buffer.add_string buf "<?/>";
                                        aux tags
                                | h :: t ->
                                        Buffer.add_string buf "</";
@@ -146,7 +147,7 @@
 
 module Parser = struct
 
-       (* Specific helpers *)
+       (* Helpers *)
        let get_data input =
                match Xmlm.input input with
                | `Data d -> d
@@ -192,44 +193,20 @@
                List.rev !r
 
 
-       (* Basic constructors *)
-       let make_int ?callback accu data : Rpc.Val.t =
-               let r = `Int (Int64.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_bool ?callback accu data : Rpc.Val.t =
-               let r = `Bool (bool_of_string 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 =
@@ -240,13 +217,15 @@
                        | 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
@@ -278,7 +257,7 @@
                        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
@@ -288,11 +267,9 @@
        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
diff -r 5158e68dfc6b -r 383e08728219 rpc-light/xmlrpc.mli
--- a/rpc-light/xmlrpc.mli      Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/xmlrpc.mli      Fri Jan 08 13:47:46 2010 +0000
@@ -12,8 +12,8 @@
  * 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
diff -r 5158e68dfc6b -r 383e08728219 stdext/META.in
--- a/stdext/META.in    Fri Jan 08 13:47:46 2010 +0000
+++ b/stdext/META.in    Fri Jan 08 13:47:46 2010 +0000
@@ -1,5 +1,5 @@
 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"
17 files changed, 674 insertions(+), 549 deletions(-)
forking_executioner/Makefile    |    4 
rpc-light/META                  |   34 +++
rpc-light/META-jsonrpc          |    4 
rpc-light/META-rpc-light        |   11 -
rpc-light/META-xmlrpc           |    5 
rpc-light/Makefile              |   70 ++-----
rpc-light/examples/Makefile     |    2 
rpc-light/examples/all_types.ml |   86 +++++----
rpc-light/jsonrpc.ml            |   94 ++++-----
rpc-light/jsonrpc.mli           |    4 
rpc-light/p4_rpc.ml             |  369 +++++++++++++++++++++++++++++++++++++++
rpc-light/pa_rpc.ml             |  291 ------------------------------
rpc-light/rpc.ml                |   68 ++++---
rpc-light/rpc.mli               |   58 ++++++
rpc-light/xmlrpc.ml             |  117 ++++--------
rpc-light/xmlrpc.mli            |    4 
stdext/META.in                  |    2 


Attachment: xen-api-libs.hg-17.patch
Description: Text Data

_______________________________________________
xen-api mailing list
xen-api@xxxxxxxxxxxxxxxxxxx
http://lists.xensource.com/mailman/listinfo/xen-api

 


Rackspace

Lists.xenproject.org is hosted with RackSpace, monitoring our
servers 24x7x365 and backed by RackSpace's Fanatical Support®.