# HG changeset patch
# User Thomas Gazagnaire <thomas.gazagnaire@xxxxxxxxxx>
# Date 1262958466 0
# Node ID 8e5e1af38c22077f98510231918d83ff5c715e05
# Parent  91091e97839df807f73ddbd9ff40ab1e13d7753d
[rpc-light] Add some explicit runtime exceptions when an runtime error occurs.

A friendly error message is displayed as well if Rpc.set_debug true is called before.

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

diff -r 91091e97839d -r 8e5e1af38c22 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
@@ -103,7 +103,6 @@
 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
@@ -216,121 +215,126 @@
 
 	let str_of_id id = match id with <:expr@loc< $lid:s$ >> -> <:expr@loc< $str:s$ >> | _ -> assert false
 
-	let runtime_error id expected =
+	let runtime_error name 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$)
+		<: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__)) }
 		>>
 
-	let runtime_exn_error id doing =
+	let runtime_exn_error name 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$)
-		>>
+		<: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 rec create id ctyp =
+	let rec create name 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< unit >>   -> <:expr< match $id$ with [ Rpc.Null -> () | $runtime_error name 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)"$ ] >>
+			| $runtime_error name 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)"$ ] >>
+			| $runtime_error name 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)"$ ] >>
+			| $runtime_error name id "Int(int64)"$ ] >>
 
 		| <:ctyp< float >>  ->
 			<:expr< match $id$ with [
 			  Rpc.Float x  -> x
 			| Rpc.String s -> float_of_string s
-			| $runtime_error id "Float"$ ] >>
+			| $runtime_error name 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)"$ ] >>
+			| $runtime_error name 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< 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< [< $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 exprs = List.map2 (create name) 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 fail_match = <:match_case< $runtime_error name 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[_]"$ ] >>
+			<:expr< match $id$ with [ Rpc.Enum [] -> None | Rpc.Enum [ $npid$ ] -> Some $create name nid t$ | $runtime_error name 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
+			let exprs = List.map2 (create name) 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"$ ]
+				[ Rpc.Enum $patt_list_of_list _loc pids$ -> $expr_tuple_of_list _loc exprs$ | $runtime_error name 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"$ ]
+				[ Rpc.Enum $npid$ -> List.map (fun $npid2$ -> $create name nid2 t$) $nid$ | $runtime_error name 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"$ ]
+				[ Rpc.Enum $npid$ -> Array.of_list (List.map (fun $npid2$ -> $create name nid2 t$) $nid$) | $runtime_error name 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 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 nid ("Looking for key "^n)$ ] >>
+					<: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 id "Dict"$ ]
+				[ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in { $rbSem_of_list exprs$ } | $runtime_error name 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 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 nid ("Looking for key "^n)$ ] >>
+					<: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 id "Dict"$ ]
+				[ Rpc.Dict $npid$ -> let $biAnd_of_list bindings$ in object $crSem_of_list exprs$ end | $runtime_error name id "Dict"$ ]
 			>>
 
 		| <:ctyp< '$lid:a$ >>             -> <:expr< $lid:of_rpc_polyvar a$ $id$ >>
@@ -338,8 +342,8 @@
 		| <: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
+		| <: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
 
 		| _ -> type_not_supported ctyp
 
@@ -349,7 +353,7 @@
 		<: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$ >>)
+				(<:expr< fun $pid$ -> $create name id ctyp$ >>)
 				args$
 		>>
 
diff -r 91091e97839d -r 8e5e1af38c22 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,6 +12,10 @@
  * GNU Lesser General Public License for more details.
  *)
 
+let debug = ref false
+let set_debug x = debug := x
+let get_debug () = !debug
+
 type t =
 	| Int of int64
 	| Bool of bool
@@ -20,6 +24,9 @@
 	| Enum of t list
 	| Dict of (string * t) list
 	| Null
+
+exception Runtime_error of string * t
+exception Runtime_exception of string * string
 
 open Printf
 let map_strings sep fn l = String.concat sep (List.map fn l)
diff -r 91091e97839d -r 8e5e1af38c22 rpc-light/rpc.mli
--- a/rpc-light/rpc.mli	Fri Jan 08 13:47:46 2010 +0000
+++ b/rpc-light/rpc.mli	Fri Jan 08 13:47:46 2010 +0000
@@ -56,3 +56,12 @@
 
 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