xmlprotocol: Marshal_error carries the reason

5 files changed, 44 insertions, 42 deletions

diff --git a/ide/coq.ml b/ide/coq.ml
index 82fd48c9e..61f002576 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -357,7 +357,9 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all =
 
 let print_exception = function
   | Xml_parser.Error e -> Xml_parser.error e
-  | Serialize.Marshal_error -> "Protocol violation"
+  | Serialize.Marshal_error(expected,actual) ->
+      "Protocol violation. Expected: " ^ expected ^ " Actual: "
+        ^ Xml_printer.to_string actual
   | e -> Printexc.to_string e
 
 let input_watch handle respawner feedback_processor =
diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml
index 0e09d8409..9071410e5 100644
--- a/ide/ide_slave.ml
+++ b/ide/ide_slave.ml
@@ -499,7 +499,7 @@ let loop () =
       | Xml_parser.Error (err, loc) ->
         pr_debug ("Syntax error in query: " ^ Xml_parser.error_msg err);
         exit 1
-      | Serialize.Marshal_error ->
+      | Serialize.Marshal_error _ ->
         pr_debug "Incorrect query.";
         exit 1
       | any ->
diff --git a/ide/serialize.ml b/ide/serialize.ml
index 685ec6049..7b568501e 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))
diff --git a/ide/serialize.mli b/ide/serialize.mli
index d7c14e7e7..bf9e184eb 100644
--- a/ide/serialize.mli
+++ b/ide/serialize.mli
@@ -8,7 +8,7 @@
 
 open Xml_datatype
 
-exception Marshal_error
+exception Marshal_error of string * xml
 
 val massoc: string -> (string * string) list -> string
 val constructor: string -> string -> xml list -> xml
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
index 45279a7c3..f1382fbcf 100644
--- a/ide/xmlprotocol.ml
+++ b/ide/xmlprotocol.ml
@@ -39,7 +39,7 @@ let to_search_cst = do_match "search_cst" (fun s args -> match s with
   | "subtype_pattern" -> SubType_Pattern (to_string (singleton args))
   | "in_module" -> In_Module (to_list to_string (singleton args))
   | "include_blacklist" -> Include_Blacklist
-  | _ -> raise Marshal_error)
+  | x -> raise (Marshal_error("search",PCData x)))
 
 let of_coq_object f ans =
   let prefix = of_list of_string ans.coq_object_prefix in
@@ -56,7 +56,7 @@ let to_coq_object f = function
     coq_object_qualid = qualid;
     coq_object_object = obj;
   }
-| _ -> raise Marshal_error
+| x -> raise (Marshal_error("coq_object",x))
 
 let of_option_value = function
   | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i]
@@ -68,7 +68,7 @@ let to_option_value = do_match "option_value" (fun s args -> match s with
   | "boolvalue" -> BoolValue (to_bool (singleton args))
   | "stringvalue" -> StringValue (to_string (singleton args))
   | "stringoptvalue" -> StringOptValue (to_option to_string (singleton args))
-  | _ -> raise Marshal_error)
+  | x -> raise (Marshal_error("*value",PCData x)))
 
 let of_option_state s =
   Element ("option_state", [], [
@@ -82,7 +82,7 @@ let to_option_state = function
       opt_depr = to_bool depr;
       opt_name = to_string name;
       opt_value = to_option_value value }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("option_state",x))
 
 let to_stateid = function
   | Element ("state_id",["val",i],[]) ->
@@ -95,7 +95,7 @@ let of_stateid i = Element ("state_id",["val",string_of_int (Stateid.to_int i)],
 let of_richpp x = Element ("richpp", [], [Richpp.repr x])
 let to_richpp xml = match xml with
   | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x
-  | _ -> raise Serialize.Marshal_error
+  | x -> raise Serialize.(Marshal_error("richpp",x))
 
 let of_value f = function
 | Good x -> Element ("value", ["val", "good"], [f x])
@@ -116,14 +116,14 @@ let to_value f = function
         let loc_s = int_of_string (Serialize.massoc "loc_s" attrs) in
         let loc_e = int_of_string (Serialize.massoc "loc_e" attrs) in
         Some (loc_s, loc_e)
-      with Marshal_error | Failure _ -> None
+      with Marshal_error _ | Failure _ -> None
     in
-    let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise Marshal_error in
+    let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in
     let id = to_stateid id in
     let msg = to_richpp msg in
     Fail (id, loc, msg)
-  else raise Marshal_error
-| _ -> raise Marshal_error
+  else raise (Marshal_error("good or fail",PCData ans))
+| x -> raise (Marshal_error("value",x))
 
 let of_status s =
   let of_so = of_option of_string in
@@ -139,12 +139,12 @@ let to_status = function
       status_proofname = to_option to_string name;
       status_allproofs = to_list to_string prfs;
       status_proofnum = to_int pnum; }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("status",x))
 
 let of_evar s = Element ("evar", [], [PCData s.evar_info])
 let to_evar = function
   | Element ("evar", [], data) -> { evar_info = raw_string data; }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("evar",x))
 
 let of_goal g =
   let hyp = of_list of_richpp g.goal_hyp in
@@ -157,7 +157,7 @@ let to_goal = function
     let ccl = to_richpp ccl in
     let id = to_string id in
     { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("goal",x))
 
 let of_goals g =
   let of_glist = of_list of_goal in
@@ -175,7 +175,7 @@ let to_goals = function
     let given_up = to_list to_goal given_up in
     { fg_goals = fg; bg_goals = bg; shelved_goals = shelf;
       given_up_goals = given_up }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("goals",x))
 
 let of_coq_info info =
   let version = of_string info.coqtop_version in
@@ -189,7 +189,7 @@ let to_coq_info = function
       protocol_version = to_string protocol;
       release_date = to_string release;
       compile_date = to_string compile; }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("coq_info",x))
 
 end
 include Xml_marshalling
@@ -695,7 +695,7 @@ let to_call : xml -> unknown_call =
     | "StopWorker" -> Unknown (StopWorker (mkCallArg stop_worker_sty_t a))
     | "PrintAst"   -> Unknown (PrintAst   (mkCallArg print_ast_sty_t   a))
     | "Annotate"   -> Unknown (Annotate   (mkCallArg annotate_sty_t    a))
-    | _ -> raise Marshal_error)
+    | x -> raise (Marshal_error("call",PCData x)))
 
 (** Debug printing *)
 
@@ -782,7 +782,7 @@ let to_message_level =
   | "notice" -> Notice
   | "warning" -> Warning
   | "error" -> Error
-  | _ -> raise Serialize.Marshal_error)
+  | x -> raise Serialize.(Marshal_error("error level",PCData x)))
 
 let of_message lvl msg =
   let lvl     = of_message_level lvl in
@@ -818,8 +818,7 @@ let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with
       FileLoaded (to_string dirpath, to_string filename)
   | "message", [lvl; content] ->
      Message (to_message_level lvl, to_richpp content)
-
-  | _ -> raise Marshal_error)
+  | x,l -> raise (Marshal_error("feedback_content",PCData (x ^ " with attributes " ^ string_of_int (List.length l)))))
 
 let of_feedback_content = function
   | AddedAxiom -> constructor "feedback_content" "addedaxiom" []
@@ -880,7 +879,7 @@ let to_feedback xml = match xml with
       id = State(to_stateid id);
       route = int_of_string route;
       contents = to_feedback_content content }
-  | _ -> raise Marshal_error
+  | x -> raise (Marshal_error("feedback",x))
 
 let is_feedback = function
   | Element ("feedback", _, _) -> true