xmlprotocol: Marshal_error carries the reason

1 files changed, 21 insertions, 20 deletions

diff --git a/ide/serialize.ml b/ide/serialize.ml
index 685ec6049c..7b568501ed 100644
--- a/ide/serialize.ml
+++ b/ide/serialize.ml
@@ -8,7 +8,7 @@
 
 open Xml_datatype
 
-exception Marshal_error
+exception Marshal_error of string * xml
 
 (** Utility functions *)
 
@@ -19,30 +19,31 @@ let rec get_attr attr = function
 
 let massoc x l =
   try get_attr x l
-  with Not_found -> raise Marshal_error
+  with Not_found -> raise (Marshal_error("attribute " ^ x,PCData "not there"))
 
 let constructor t c args = Element (t, ["val", c], args)
 let do_match t mf = function
   | Element (s, attrs, args) when CString.equal s t ->
       let c = massoc "val" attrs in
       mf c args
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error (t,x))
 
 let singleton = function
   | [x] -> x
-  | _ -> raise Marshal_error
+  | l -> raise (Marshal_error
+      ("singleton",PCData ("list of length " ^ string_of_int (List.length l))))
 
 let raw_string = function
   | [] -> ""
   | [PCData s] -> s
-  | _ -> raise Marshal_error
+  | x::_ -> raise (Marshal_error("raw string",x))
 
 (** Base types *)
 
 let of_unit () = Element ("unit", [], [])
 let to_unit : xml -> unit = function
   | Element ("unit", [], []) -> ()
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error ("unit",x))
 
 let of_bool (b : bool) : xml =
   if b then constructor "bool" "true" []
@@ -50,13 +51,13 @@ let of_bool (b : bool) : xml =
 let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with
   | "true" -> true
   | "false" -> false
-  | _ -> raise Marshal_error)
+  | x -> raise (Marshal_error("bool",PCData x)))
 
 let of_list (f : 'a -> xml) (l : 'a list) =
   Element ("list", [], List.map f l)
 let to_list (f : xml -> 'a) : xml -> 'a list = function
   | Element ("list", [], l) -> List.map f l
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("list",x))
 
 let of_option (f : 'a -> xml) : 'a option -> xml = function
   | None -> Element ("option", ["val", "none"], [])
@@ -64,24 +65,24 @@ let of_option (f : 'a -> xml) : 'a option -> xml = function
 let to_option (f : xml -> 'a) : xml -> 'a option = function
   | Element ("option", ["val", "none"], []) -> None
   | Element ("option", ["val", "some"], [x]) -> Some (f x)
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("option",x))
 
 let of_string (s : string) : xml = Element ("string", [], [PCData s])
 let to_string : xml -> string = function
   | Element ("string", [], l) -> raw_string l
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("string",x))
 
 let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)])
 let to_int : xml -> int = function
   | Element ("int", [], [PCData s]) ->
-    (try int_of_string s with Failure _ -> raise Marshal_error)
-  | _ -> raise Marshal_error
+    (try int_of_string s with Failure _ -> raise(Marshal_error("int",PCData s)))
+  | x -> raise (Marshal_error("int",x))
 
 let of_pair (f : 'a -> xml) (g : 'b -> xml) (x : 'a * 'b) : xml =
   Element ("pair", [], [f (fst x); g (snd x)])
 let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function
   | Element ("pair", [], [x; y]) -> (f x, g y)
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("pair",x))
 
 let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = function
   | CSig.Inl x -> Element ("union", ["val","in_l"], [f x])
@@ -89,7 +90,7 @@ let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = funct
 let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) CSig.union = function
   | Element ("union", ["val","in_l"], [x]) -> CSig.Inl (f x)
   | Element ("union", ["val","in_r"], [x]) -> CSig.Inr (g x)
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("union",x))
 
 (** More elaborate types *)
 
@@ -99,7 +100,7 @@ let to_edit_id = function
       let id = int_of_string i in
       assert (id <= 0 );
       id
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("edit_id",x))
 
 let of_loc loc =
   let start, stop = Loc.unloc loc in
@@ -107,14 +108,14 @@ let of_loc loc =
 let to_loc xml =
   match xml with
   | Element ("loc", l,[]) ->
+      let start = massoc "start" l in
+      let stop = massoc "stop" l in
       (try
-        let start = massoc "start" l in
-        let stop = massoc "stop" l in
         Loc.make_loc (int_of_string start, int_of_string stop)
-      with Not_found | Invalid_argument _ -> raise Marshal_error)
-  | _ -> raise Marshal_error
+      with Not_found | Invalid_argument _ -> raise (Marshal_error("loc",PCData(start^":"^stop))))
+  | x -> raise (Marshal_error("loc",x))
 
 let of_xml x = Element ("xml", [], [x])
 let to_xml xml = match xml with
 | Element ("xml", [], [x]) -> x
-| _ -> raise Marshal_error
+| x -> raise (Marshal_error("xml",x))