# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
# Date 1262958466 0
# Node ID bca2a17d2f9e9af21773061a902be48f990c4f08
# Parent  a571cd80dcb8a38c72b58bbc05b49cf14409c883
[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@xxxxxxxxxx>

diff -r a571cd80dcb8 -r bca2a17d2f9e 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
@@ -8,7 +8,8 @@
 	phantom \
 	xapi \
 	option \
-	encoding
+	encoding \
+	dict
 
 EXECS=$(foreach example, $(EXAMPLES), $(example).opt)
 
diff -r a571cd80dcb8 -r bca2a17d2f9e rpc-light/examples/dict.ml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/rpc-light/examples/dict.ml	Fri Jan 08 13:47:46 2010 +0000
@@ -0,0 +1,12 @@
+type key = string with rpc
+
+type t = (key * float) list with rpc
+
+let _ = 
+	let t = [ "foo", 3. ; "bar", 4. ] in
+	let r = rpc_of_t t in
+	Printf.printf "r = %s\n%!" (Rpc.to_string r);
+
+	let t' = t_of_rpc r in
+	Printf.printf "t = t' : %b\n%!" (t = t');
+	assert (t = t')
diff -r a571cd80dcb8 -r bca2a17d2f9e 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
@@ -19,7 +19,13 @@
 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 @@
 	| <: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
 	
@@ -159,6 +172,23 @@
 		| <:ctyp< char >>    -> <:expr< Rpc.Int (Int64.of_int (Char.code $id$)) >>
 		| <: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
@@ -302,6 +332,26 @@
 		| <: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 =