From 6ce98a380f8af0ab42cda6c1a46cd3a2356b54e8 Mon Sep 17 00:00:00 2001
From: Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
Date: Mon, 11 Jan 2010 17:44:38 +0000
Subject: [PATCH] [rpc-light] Optimize the way (string * t) list are marshaled

This bit is necessary to discuss with the SM backend and it is also a nice optiomization. Basically, if you have: 'type t = (kk, vv) list with rpc' the library will check if value of type 'kk' are marshaled to a string; if yes, instead of having a list of stuff, it creates a dictionary which is what the python XenAPI bindings are looking for.

Signed-off-by: Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
---
 rpc-light/examples/Makefile |  3 ++-
 rpc-light/p4_rpc.ml         | 50 +++++++++++++++++++++++++++++++++++++
 2 files changed, 52 insertions(+), 1 deletion(-)

diff --git a/rpc-light/examples/Makefile b/rpc-light/examples/Makefile
index bbfdff4..9a3bac5 100644
--- a/rpc-light/examples/Makefile
+++ b/rpc-light/examples/Makefile
@@ -8,7 +8,8 @@ EXAMPLES = \
 	phantom \
 	xapi \
 	option \
-	encoding
+	encoding \
+	dict
 
 EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
 
diff --git a/rpc-light/p4_rpc.ml b/rpc-light/p4_rpc.ml
index d117385..2cb5b02 100644
--- a/rpc-light/p4_rpc.ml
+++ b/rpc-light/p4_rpc.ml
@@ -19,7 +19,13 @@ open PreCast
 open Ast
 open Syntax
 
+
+let is_base = function
+	| "int64" | "int32" | "int" | "flaot" | "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 ^ "__"
@@ -126,6 +132,13 @@ 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
 	
@@ -160,6 +173,23 @@ module Rpc_of = struct
 		| <: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< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
 			let ids, ctyps = decompose_variants _loc t in
 			let pattern (n, t) ctyps =
@@ -302,6 +332,26 @@ module Of_rpc = struct
 		| <: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< [< $t$ ] >> | <:ctyp< [> $t$ ] >> | <:ctyp< [= $t$ ] >> | <:ctyp< [ $t$ ] >> ->
 			let ids, ctyps = decompose_variants _loc t in
 			let pattern (n, t) ctyps =
-- 
2.39.5