[Xen-API] [PATCH 12 of 17] [rpc-light] Do not wait for an optional field when unparsing an {JSON, XML}RPC

[Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>]

# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
# Date 1262958466 0
# Node ID 009c14391cf870a2a283973727c7b839250b813e
# Parent  30e654b8fb5653bc25c415ff6b366cc2e680bf62
[rpc-light] Do not wait for an optional field when unparsing an {JSON,XML}RPC.

If you have:
type t = { foo : int option; bar : string } with rpc

It is allright to do not have the foo field if its value is None

Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>

diff -r 30e654b8fb56 -r 009c14391cf8 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
@@ -3,7 +3,11 @@
 OCAMLFLAGS = -annot -g
 
 PACKS = rpc-light
-EXAMPLES = all_types phantom xapi
+EXAMPLES = \
+       all_types \
+       phantom \
+       xapi \
+       option
 
 EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
 
diff -r 30e654b8fb56 -r 009c14391cf8 rpc-light/p4_rpc.ml
--- a/rpc-light/p4_rpc.ml       Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/p4_rpc.ml       Fri Jan 08 13:47:46 2010 +0000
@@ -122,10 +122,33 @@
                expr
                args
 
+let is_option = function
+       | <:ctyp@loc< option $_$ >> -> true
+       | _                         -> false
+
 (* Conversion ML type -> Rpc.value *)
 module Rpc_of = struct
        
-       let rec create id ctyp =
+       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 _loc = loc_of_ctyp ctyp in
                match ctyp with
                | <:ctyp< unit >>    -> <:expr< Rpc.Null >>
@@ -167,21 +190,8 @@
                        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< { $t$ } >>              -> product (fun field -> 
<:expr< $id$ . $lid:field$ >>) t
+               | <:ctyp< < $t$ > >>              -> product (fun field -> 
<:expr< $id$ # $lid:field$ >>) t
 
                | <:ctyp< '$lid:a$ >>             -> <:expr< 
$lid:rpc_of_polyvar a$ $id$  >>
 
@@ -231,6 +241,28 @@
                                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"$ ]
+               >>
 
        let rec create name id ctyp =
                let _loc = loc_of_ctyp ctyp in
@@ -312,30 +344,10 @@
                        >>
 
                | <: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 name 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 name 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 name id "Dict"$ ]
-                       >>
+                       product name (fun n i ctyp -> <:rec_binding< $lid:n$ = 
$create name i ctyp$ >>) (fun es -> <:expr< { $rbSem_of_list es$ } >>) id t
 
                | <: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 name 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 name 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 name id "Dict"$ ]
-                       >>
+                       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
 
                | <:ctyp< '$lid:a$ >>             -> <:expr< 
$lid:of_rpc_polyvar a$ $id$ >>
 
2 files changed, 55 insertions(+), 39 deletions(-)
rpc-light/examples/Makefile |    6 ++
rpc-light/p4_rpc.ml         |   88 ++++++++++++++++++++++++-------------------

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