all coqide specific files moved into ide/

lib/interface split into:
 - lib/feedback
     subscribe-based feedback bus (also used by coqidetop)
 - ide/interface
     definition of coqide protocol messages
   lib/pp
     structured info/err/warn messages

lib/serialize split into:
 - lib/serialize
     generic xml serialization (list, pairs, int, loc, ...)
     used by coqide but potentially useful to other interfaces
 - ide/xmlprotocol
     serialization of protocol messages as in ide/interface

the only drawback is that coqidetop needs -thread
and I had to pass that option to all files in ide/

14 files changed, 1504 insertions, 50 deletions

diff --git a/ide/coq.ml b/ide/coq.ml
index af00cc63cd..c1555e57f2 100644
--- a/ide/coq.ml
+++ b/ide/coq.ml
@@ -177,7 +177,7 @@ type void = Void
     Reference: http://alan.petitepomme.net/cwn/2004.01.13.html
     To rewrite someday with GADT. *)
 
-type 'a poly_ccb = 'a Serialize.call * ('a Interface.value -> void)
+type 'a poly_ccb = 'a Xmlprotocol.call * ('a Interface.value -> void)
 type 't scoped_ccb = { bind_ccb : 'a. 'a poly_ccb -> 't }
 type ccb = { open_ccb : 't. 't scoped_ccb -> 't }
 
@@ -234,7 +234,7 @@ type coqtop = {
   (* called whenever coqtop dies *)
   mutable reset_handler : reset_kind -> unit task;
   (* called whenever coqtop sends a feedback message *)
-  mutable feedback_handler : Interface.feedback -> unit;
+  mutable feedback_handler : Feedback.feedback -> unit;
   (* actual coqtop process and its status *)
   mutable handle : handle;
   mutable status : status;
@@ -296,22 +296,22 @@ let rec check_errors = function
 | `OUT :: _ -> raise (TubeError "OUT")
 
 let handle_intermediate_message handle xml =
-  let message = Serialize.to_message xml in
-  let level = message.Interface.message_level in
-  let content = message.Interface.message_content in
+  let message = Pp.to_message xml in
+  let level = message.Pp.message_level in
+  let content = message.Pp.message_content in
   let logger = match handle.waiting_for with
     | Some (_, l) -> l 
     | None -> function
-        | Interface.Error -> Minilib.log ~level:`ERROR
-        | Interface.Info -> Minilib.log ~level:`INFO
-        | Interface.Notice -> Minilib.log ~level:`NOTICE
-        | Interface.Warning -> Minilib.log ~level:`WARNING
-        | Interface.Debug _ -> Minilib.log ~level:`DEBUG
+        | Pp.Error -> Minilib.log ~level:`ERROR
+        | Pp.Info -> Minilib.log ~level:`INFO
+        | Pp.Notice -> Minilib.log ~level:`NOTICE
+        | Pp.Warning -> Minilib.log ~level:`WARNING
+        | Pp.Debug _ -> Minilib.log ~level:`DEBUG
   in
   logger level content
 
 let handle_feedback feedback_processor xml =
-  let feedback = Serialize.to_feedback xml in
+  let feedback = Feedback.to_feedback xml in
   feedback_processor feedback
 
 let handle_final_answer handle xml =
@@ -320,7 +320,7 @@ let handle_final_answer handle xml =
     | None -> raise (AnswerWithoutRequest (Xml_printer.to_string_fmt xml))
     | Some (c, _) -> c in
   let () = handle.waiting_for <- None in
-  with_ccb ccb { bind_ccb = fun (c, f) -> f (Serialize.to_answer c xml) }
+  with_ccb ccb { bind_ccb = fun (c, f) -> f (Xmlprotocol.to_answer c xml) }
 
 type input_state = {
   mutable fragment : string;
@@ -340,10 +340,10 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all =
     let l_end = Lexing.lexeme_end lex in
     state.fragment <- String.sub s l_end (String.length s - l_end);
     state.lexerror <- None;
-    if Serialize.is_message xml then begin
+    if Pp.is_message xml then begin
       handle_intermediate_message handle xml;
       loop ()
-    end else if Serialize.is_feedback xml then begin
+    end else if Feedback.is_feedback xml then begin
       handle_feedback feedback_processor xml;
       loop ()
     end else begin
@@ -501,22 +501,22 @@ type 'a query = 'a Interface.value task
 
 let eval_call ?(logger=default_logger) call handle k =
   (** Send messages to coqtop and prepare the decoding of the answer *)
-  Minilib.log ("Start eval_call " ^ Serialize.pr_call call);
+  Minilib.log ("Start eval_call " ^ Xmlprotocol.pr_call call);
   assert (handle.alive && handle.waiting_for = None);
   handle.waiting_for <- Some (mk_ccb (call,k), logger);
-  Xml_printer.print handle.xml_oc (Serialize.of_call call);
+  Xml_printer.print handle.xml_oc (Xmlprotocol.of_call call);
   Minilib.log "End eval_call";
   Void
 
-let add ?(logger=default_logger) x = eval_call ~logger (Serialize.add x)
-let edit_at i = eval_call (Serialize.edit_at i)
-let query ?(logger=default_logger) x = eval_call ~logger (Serialize.query x)
-let mkcases s = eval_call (Serialize.mkcases s)
-let status ?logger force = eval_call ?logger (Serialize.status force)
-let hints x = eval_call (Serialize.hints x)
-let search flags = eval_call (Serialize.search flags)
-let init x = eval_call (Serialize.init x)
-let stop_worker x = eval_call (Serialize.stop_worker x)
+let add ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.add x)
+let edit_at i = eval_call (Xmlprotocol.edit_at i)
+let query ?(logger=default_logger) x = eval_call ~logger (Xmlprotocol.query x)
+let mkcases s = eval_call (Xmlprotocol.mkcases s)
+let status ?logger force = eval_call ?logger (Xmlprotocol.status force)
+let hints x = eval_call (Xmlprotocol.hints x)
+let search flags = eval_call (Xmlprotocol.search flags)
+let init x = eval_call (Xmlprotocol.init x)
+let stop_worker x = eval_call (Xmlprotocol.stop_worker x)
 
 module PrintOpt =
 struct
@@ -573,7 +573,7 @@ struct
     let mkopt o v acc = (o, Interface.BoolValue v) :: acc in
     let opts = Hashtbl.fold mkopt current_state [] in
     let opts = (width, Interface.IntValue !width_state) :: opts in
-    eval_call (Serialize.set_options opts) h
+    eval_call (Xmlprotocol.set_options opts) h
       (function
 	| Interface.Good () -> k ()
 	| _ -> failwith "Cannot set options. Resetting coqtop")
@@ -581,7 +581,7 @@ struct
 end
 
 let goals ?logger x h k =
-  PrintOpt.enforce h (fun () -> eval_call ?logger (Serialize.goals x) h k)
+  PrintOpt.enforce h (fun () -> eval_call ?logger (Xmlprotocol.goals x) h k)
 
 let evars x h k =
-  PrintOpt.enforce h (fun () -> eval_call (Serialize.evars x) h k)
+  PrintOpt.enforce h (fun () -> eval_call (Xmlprotocol.evars x) h k)
diff --git a/ide/coq.mli b/ide/coq.mli
index 542cc44620..966c77700e 100644
--- a/ide/coq.mli
+++ b/ide/coq.mli
@@ -63,7 +63,7 @@ val spawn_coqtop : string list -> coqtop
 val set_reset_handler : coqtop -> (reset_kind -> unit task) -> unit
 (** Register a handler called when a coqtop dies (badly or on purpose) *)
 
-val set_feedback_handler : coqtop -> (Interface.feedback -> unit) -> unit
+val set_feedback_handler : coqtop -> (Feedback.feedback -> unit) -> unit
 (** Register a handler called when coqtop sends a feedback message *)
 
 val init_coqtop : coqtop -> unit task -> unit
diff --git a/ide/coqOps.ml b/ide/coqOps.ml
index ab1a86f78a..cefe18092b 100644
--- a/ide/coqOps.ml
+++ b/ide/coqOps.ml
@@ -10,6 +10,7 @@ open Util
 open Coq
 open Ideutils
 open Interface
+open Feedback
 
 type flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR of string ]
 type mem_flag = [ `INCOMPLETE | `UNSAFE | `PROCESSING | `ERROR ]
@@ -422,7 +423,7 @@ object(self)
       self#position_error_tag_at_iter start phrase loc;
       buffer#place_cursor ~where:stop;
       messages#clear;
-      messages#push Error msg;
+      messages#push Pp.Error msg;
       self#show_goals
     end else
       self#show_goals_aux ~move_insert:true ()
@@ -511,7 +512,7 @@ object(self)
             let handle_answer = function
               | Good (id, (Util.Inl (* NewTip *) (), msg)) ->
                   Doc.assign_tip_id document id;
-                  logger Notice msg;
+                  logger Pp.Notice msg;
                   self#commit_queue_transaction sentence;
                   loop id []
               | Good (id, (Util.Inr (* Unfocus *) tip, msg)) ->
@@ -519,7 +520,7 @@ object(self)
                   let topstack, _ = Doc.context document in
                   self#exit_focus;
                   self#cleanup (Doc.cut_at document tip);
-                  logger Notice msg;
+                  logger Pp.Notice msg;
                   self#mark_as_needed sentence;
                   if Queue.is_empty queue then loop tip []
                   else loop tip (List.rev topstack)
@@ -538,7 +539,7 @@ object(self)
    let next = function
      | Good _ ->
          messages#clear;
-         messages#push Info "Doc checked";
+         messages#push Pp.Info "Doc checked";
          Coq.return ()
      | Fail x -> self#handle_failure x in
    Coq.bind (Coq.status ~logger:messages#push true) next
@@ -628,8 +629,8 @@ object(self)
           self#cleanup (Doc.cut_at document to_id);
           conclusion ()
       | Fail (safe_id, loc, msg) ->
-          if loc <> None then messages#push Error "Fixme LOC";
-          messages#push Error msg;
+          if loc <> None then messages#push Pp.Error "Fixme LOC";
+          messages#push Pp.Error msg;
           if Stateid.equal safe_id Stateid.dummy then self#show_goals
           else undo safe_id
                  (Doc.focused document && Doc.is_in_focus document safe_id))
@@ -647,7 +648,7 @@ object(self)
     ?(move_insert=false) (safe_id, (loc : (int * int) option), msg)
   =
     messages#clear;
-    messages#push Error msg;
+    messages#push Pp.Error msg;
     ignore(self#process_feedback ());
     if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ())
     else
diff --git a/ide/coqide.ml b/ide/coqide.ml
index e20c95b9eb..9614c6f3b1 100644
--- a/ide/coqide.ml
+++ b/ide/coqide.ml
@@ -739,7 +739,7 @@ let coqtop_arguments sn =
         let args = String.concat " " args in
         let msg = Printf.sprintf "Invalid arguments: %s" args in
         let () = sn.messages#clear in
-        sn.messages#push Interface.Error msg
+        sn.messages#push Pp.Error msg
     else dialog#destroy ()
   in
   let _ = entry#connect#activate ok_cb in
diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib
new file mode 100644
index 0000000000..92301dc30e
--- /dev/null
+++ b/ide/coqidetop.mllib
@@ -0,0 +1,2 @@
+Xmlprotocol
+Ide_slave
diff --git a/ide/ide.mllib b/ide/ide.mllib
index 8bc1337ff1..9444761716 100644
--- a/ide/ide.mllib
+++ b/ide/ide.mllib
@@ -15,6 +15,7 @@ Utf8_convert
 Preferences
 Project_file
 Ideutils
+Xmlprotocol
 Coq
 Coq_lex
 Sentence
diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml
new file mode 100644
index 0000000000..6b2c52123d
--- /dev/null
+++ b/ide/ide_slave.ml
@@ -0,0 +1,460 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Vernacexpr
+open Errors
+open Util
+open Pp
+open Printer
+
+(** Ide_slave : an implementation of [Interface], i.e. mainly an interp
+    function and a rewind function. This specialized loop is triggered
+    when the -ideslave option is passed to Coqtop. Currently CoqIDE is
+    the only one using this mode, but we try here to be as generic as
+    possible, so this may change in the future... *)
+
+(** Signal handling: we postpone ^C during input and output phases,
+    but make it directly raise a Sys.Break during evaluation of the request. *)
+
+let catch_break = ref false
+
+let init_signal_handler () =
+  let f _ = if !catch_break then raise Sys.Break else Control.interrupt := true in
+  Sys.set_signal Sys.sigint (Sys.Signal_handle f)
+
+
+(** Redirection of standard output to a printable buffer *)
+
+let init_stdout, read_stdout =
+  let out_buff = Buffer.create 100 in
+  let out_ft = Format.formatter_of_buffer out_buff in
+  let deep_out_ft = Format.formatter_of_buffer out_buff in
+  let _ = Pp_control.set_gp deep_out_ft Pp_control.deep_gp in
+  (fun () ->
+     flush_all ();
+     Pp_control.std_ft := out_ft;
+     Pp_control.err_ft := out_ft;
+     Pp_control.deep_ft := deep_out_ft;
+  ),
+  (fun () -> Format.pp_print_flush out_ft ();
+             let r = Buffer.contents out_buff in
+             Buffer.clear out_buff; r)
+
+let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s
+
+let pr_debug s =
+  if !Flags.debug then pr_with_pid s
+let pr_debug_call q =
+  if !Flags.debug then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q)
+let pr_debug_answer q r =
+  if !Flags.debug then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r)
+
+(** Categories of commands *)
+
+let coqide_known_option table = List.mem table [
+  ["Printing";"Implicit"];
+  ["Printing";"Coercions"];
+  ["Printing";"Matching"];
+  ["Printing";"Synth"];
+  ["Printing";"Notations"];
+  ["Printing";"All"];
+  ["Printing";"Records"];
+  ["Printing";"Existential";"Instances"];
+  ["Printing";"Universes"]]
+
+let is_known_option cmd = match cmd with
+  | VernacSetOption (o,BoolValue true)
+  | VernacUnsetOption o -> coqide_known_option o
+  | _ -> false
+
+let is_debug cmd = match cmd with
+  | VernacSetOption (["Ltac";"Debug"], _) -> true
+  | _ -> false
+
+let is_query cmd = match cmd with
+  | VernacChdir None
+  | VernacMemOption _
+  | VernacPrintOption _
+  | VernacCheckMayEval _
+  | VernacGlobalCheck _
+  | VernacPrint _
+  | VernacSearch _
+  | VernacLocate _ -> true
+  | _ -> false
+
+let is_undo cmd = match cmd with
+  | VernacUndo _ | VernacUndoTo _ -> true
+  | _ -> false
+
+(** Check whether a command is forbidden by CoqIDE *)
+
+let coqide_cmd_checks (loc,ast) =
+  let user_error s = Errors.user_err_loc (loc, "CoqIde", str s) in
+  if is_debug ast then
+    user_error "Debug mode not available within CoqIDE";
+  if is_known_option ast then
+    msg_warning (strbrk"This will not work. Use CoqIDE display menu instead");
+  if Vernac.is_navigation_vernac ast || is_undo ast then
+    msg_warning (strbrk "Rather use CoqIDE navigation instead");
+  if is_query ast then
+    msg_warning (strbrk "Query commands should not be inserted in scripts")
+
+(** Interpretation (cf. [Ide_intf.interp]) *)
+
+let add ((s,eid),(sid,verbose)) =
+  let newid, rc = Stm.add ~ontop:sid verbose ~check:coqide_cmd_checks eid s in
+  let rc = match rc with `NewTip -> CSig.Inl () | `Unfocus id -> CSig.Inr id in
+  newid, (rc, read_stdout ())
+
+let edit_at id =
+  match Stm.edit_at id with
+  | `NewTip -> CSig.Inl ()
+  | `Focus { Stm.start; stop; tip} -> CSig.Inr (start, (stop, tip))
+
+let query (s,id) = Stm.query ~at:id s; read_stdout ()
+
+(** Goal display *)
+
+let hyp_next_tac sigma env (id,_,ast) =
+  let id_s = Names.Id.to_string id in
+  let type_s = string_of_ppcmds (pr_ltype_env env ast) in
+  [
+    ("clear "^id_s),("clear "^id_s^".");
+    ("apply "^id_s),("apply "^id_s^".");
+    ("exact "^id_s),("exact "^id_s^".");
+    ("generalize "^id_s),("generalize "^id_s^".");
+    ("absurd <"^id_s^">"),("absurd "^type_s^".")
+  ] @ [
+    ("discriminate "^id_s),("discriminate "^id_s^".");
+    ("injection "^id_s),("injection "^id_s^".")
+  ] @ [
+    ("rewrite "^id_s),("rewrite "^id_s^".");
+    ("rewrite <- "^id_s),("rewrite <- "^id_s^".")
+  ] @ [
+    ("elim "^id_s), ("elim "^id_s^".");
+    ("inversion "^id_s), ("inversion "^id_s^".");
+    ("inversion clear "^id_s), ("inversion_clear "^id_s^".")
+  ]
+
+let concl_next_tac sigma concl =
+  let expand s = (s,s^".") in
+  List.map expand ([
+    "intro";
+    "intros";
+    "intuition"
+  ] @ [
+    "reflexivity";
+    "discriminate";
+    "symmetry"
+  ] @ [
+    "assumption";
+    "omega";
+    "ring";
+    "auto";
+    "eauto";
+    "tauto";
+    "trivial";
+    "decide equality";
+    "simpl";
+    "subst";
+    "red";
+    "split";
+    "left";
+    "right"
+  ])
+
+let process_goal sigma g =
+  let env = Goal.V82.env sigma g in
+  let id = Goal.uid g in
+  let ccl =
+    let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in
+    string_of_ppcmds (pr_goal_concl_style_env env norm_constr) in
+  let process_hyp h_env d acc =
+    let d = Context.map_named_declaration (Reductionops.nf_evar sigma) d in
+    (string_of_ppcmds (pr_var_decl h_env d)) :: acc in
+  let hyps =
+    List.rev (Environ.fold_named_context process_hyp env ~init: []) in
+  { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; }
+
+let goals () =
+  Stm.finish ();
+  let s = read_stdout () in
+  if not (String.is_empty s) then msg_info (str s);
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let (goals, zipper, shelf, given_up, sigma) = Proof.proof pfts in
+    let fg = List.map (process_goal sigma) goals in
+    let map_zip (lg, rg) =
+      let lg = List.map (process_goal sigma) lg in
+      let rg = List.map (process_goal sigma) rg in
+      (lg, rg)
+    in
+    let bg = List.map map_zip zipper in
+    let shelf = List.map (process_goal sigma) shelf in
+    let given_up = List.map (process_goal sigma) given_up in
+    Some { Interface.fg_goals = fg;
+           Interface.bg_goals = bg;
+           shelved_goals = shelf;
+           given_up_goals = given_up; }
+  with Proof_global.NoCurrentProof -> None
+
+let evars () =
+  try
+    Stm.finish ();
+    let s = read_stdout () in
+    if not (String.is_empty s) then msg_info (str s);
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in
+    let map_evar ev = { Interface.evar_info = string_of_ppcmds (pr_evar ev); } in
+    let el = List.map map_evar exl in
+    Some el
+  with Proof_global.NoCurrentProof -> None
+
+let hints () =
+  try
+    let pfts = Proof_global.give_me_the_proof () in
+    let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in
+    match all_goals with
+    | [] -> None
+    | g :: _ ->
+      let env = Goal.V82.env sigma g in
+      let hint_goal = concl_next_tac sigma g in
+      let get_hint_hyp env d accu = hyp_next_tac sigma env d :: accu in
+      let hint_hyps = List.rev (Environ.fold_named_context get_hint_hyp env ~init: []) in
+      Some (hint_hyps, hint_goal)
+  with Proof_global.NoCurrentProof -> None
+
+
+(** Other API calls *)
+
+let status force =
+  (** We remove the initial part of the current [DirPath.t]
+      (usually Top in an interactive session, cf "coqtop -top"),
+      and display the other parts (opened sections and modules) *)
+  Stm.finish ();
+  if force then Stm.join ();
+  let s = read_stdout () in
+  if not (String.is_empty s) then msg_info (str s);
+  let path =
+    let l = Names.DirPath.repr (Lib.cwd ()) in
+    List.rev_map Names.Id.to_string l
+  in
+  let proof =
+    try Some (Names.Id.to_string (Proof_global.get_current_proof_name ()))
+    with Proof_global.NoCurrentProof -> None
+  in
+  let allproofs =
+    let l = Proof_global.get_all_proof_names () in
+    List.map Names.Id.to_string l
+  in
+  {
+    Interface.status_path = path;
+    Interface.status_proofname = proof;
+    Interface.status_allproofs = allproofs;
+    Interface.status_proofnum = Stm.current_proof_depth ();
+  }
+
+let search flags = Search.interface_search flags
+
+let get_options () =
+  let table = Goptions.get_tables () in
+  let fold key state accu = (key, state) :: accu in
+  Goptions.OptionMap.fold fold table []
+
+let set_options options =
+  let iter (name, value) = match value with
+  | BoolValue b -> Goptions.set_bool_option_value name b
+  | IntValue i -> Goptions.set_int_option_value name i
+  | StringValue s -> Goptions.set_string_option_value name s
+  in
+  List.iter iter options
+
+let about () = {
+  Interface.coqtop_version = Coq_config.version;
+  Interface.protocol_version = Xmlprotocol.protocol_version;
+  Interface.release_date = Coq_config.date;
+  Interface.compile_date = Coq_config.compile_date;
+}
+
+let handle_exn e =
+  let dummy = Stateid.dummy in
+  let loc_of e = match Loc.get_loc e with
+    | Some loc when not (Loc.is_ghost loc) -> Some (Loc.unloc loc)
+    | _ -> None in
+  let mk_msg e = read_stdout ()^"\n"^string_of_ppcmds (Errors.print e) in
+  match e with
+  | Errors.Drop -> dummy, None, "Drop is not allowed by coqide!"
+  | Errors.Quit -> dummy, None, "Quit is not allowed by coqide!"
+  | e ->
+      match Stateid.get e with
+      | Some (valid, _) -> valid, loc_of e, mk_msg e
+      | None -> dummy, loc_of e, mk_msg e
+
+let init =
+  let initialized = ref false in
+  fun file ->
+   if !initialized then anomaly (str "Already initialized")
+   else begin
+     initialized := true;
+     match file with
+     | None -> Stm.get_current_state ()
+     | Some file ->
+         let dir = Filename.dirname file in
+         let open Loadpath in let open CUnix in
+         let initial_id, _ =
+           if not (is_in_load_paths (physical_path_of_string dir)) then
+             Stm.add false ~ontop:(Stm.get_current_state ())
+               0 (Printf.sprintf "Add LoadPath \"%s\". " dir)
+           else Stm.get_current_state (), `NewTip in
+         Stm.set_compilation_hints file;
+         initial_id
+   end
+
+(* Retrocompatibility stuff *)
+let interp ((_raw, verbose), s) =
+  let vernac_parse s =
+    let pa = Pcoq.Gram.parsable (Stream.of_string s) in
+    Flags.with_option Flags.we_are_parsing (fun () ->
+      match Pcoq.Gram.entry_parse Pcoq.main_entry pa with
+      | None -> raise (Invalid_argument "vernac_parse")
+      | Some ast -> ast)
+    () in
+  Stm.interp verbose (vernac_parse s);
+  Stm.get_current_state (), CSig.Inl (read_stdout ())
+
+(** When receiving the Quit call, we don't directly do an [exit 0],
+    but rather set this reference, in order to send a final answer
+    before exiting. *)
+
+let quit = ref false
+
+(** Grouping all call handlers together + error handling *)
+
+let eval_call xml_oc log c =
+  let interruptible f x =
+    catch_break := true;
+    Control.check_for_interrupt ();
+    let r = f x in
+    catch_break := false;
+    let out = read_stdout () in
+    if not (String.is_empty out) then log (str out);
+    r
+  in
+  let handler = {
+    Interface.add = interruptible add;
+    Interface.edit_at = interruptible edit_at;
+    Interface.query = interruptible query;
+    Interface.goals = interruptible goals;
+    Interface.evars = interruptible evars;
+    Interface.hints = interruptible hints;
+    Interface.status = interruptible status;
+    Interface.search = interruptible search;
+    Interface.get_options = interruptible get_options;
+    Interface.set_options = interruptible set_options;
+    Interface.mkcases = interruptible Vernacentries.make_cases;
+    Interface.quit = (fun () -> quit := true);
+    Interface.init = interruptible init;
+    Interface.about = interruptible about;
+    Interface.interp = interruptible interp;
+    Interface.handle_exn = handle_exn;
+    Interface.stop_worker = Stm.stop_worker;
+  } in
+  Xmlprotocol.abstract_eval_call handler c
+
+(** Message dispatching.
+    Since coqtop -ideslave starts 1 thread per slave, and each
+    thread forwards feedback messages from the slave to the GUI on the same
+    xml channel, we need mutual exclusion.  The mutex should be per-channel, but
+    here we only use 1 channel. *)
+let print_xml =
+  let m = Mutex.create () in
+  fun oc xml ->
+    Mutex.lock m;
+    try Xml_printer.print oc xml; Mutex.unlock m
+    with e -> let e = Errors.push e in Mutex.unlock m; raise e
+  
+
+let slave_logger xml_oc level message =
+  (* convert the message into XML *)
+  let msg = string_of_ppcmds (hov 0 message) in
+  let message = {
+    Pp.message_level = level;
+    Pp.message_content = msg;
+  } in
+  let () = pr_debug (Printf.sprintf "-> %S" msg) in
+  let xml = Pp.of_message message in
+  print_xml xml_oc xml
+
+let slave_feeder xml_oc msg =
+  let xml = Feedback.of_feedback msg in
+  print_xml xml_oc xml
+
+(** The main loop *)
+
+(** Exceptions during eval_call should be converted into [Interface.Fail]
+    messages by [handle_exn] above. Otherwise, we die badly, without
+    trying to answer malformed requests. *)
+
+let loop () =
+  init_signal_handler ();
+  catch_break := false;
+  let in_ch, out_ch = Spawned.get_channels () in
+  let xml_oc = Xml_printer.make (Xml_printer.TChannel out_ch) in
+  CThread.prepare_in_channel_for_thread_friendly_io in_ch;
+  let in_lb = Lexing.from_function (fun s len ->
+    CThread.thread_friendly_read in_ch s ~off:0 ~len) in
+  let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in
+  let () = Xml_parser.check_eof xml_ic false in
+  set_logger (slave_logger xml_oc);
+  set_feeder (slave_feeder xml_oc);
+  (* We'll handle goal fetching and display in our own way *)
+  Vernacentries.enable_goal_printing := false;
+  Vernacentries.qed_display_script := false;
+  Flags.make_term_color false;
+  while not !quit do
+    try
+      let xml_query = Xml_parser.parse xml_ic in
+(*       pr_with_pid (Xml_printer.to_string_fmt xml_query); *)
+      let q = Xmlprotocol.to_call xml_query in
+      let () = pr_debug_call q in
+      let r = eval_call xml_oc (slave_logger xml_oc Pp.Notice) q in
+      let () = pr_debug_answer q r in
+(*       pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *)
+      print_xml xml_oc (Xmlprotocol.of_answer q r);
+      flush out_ch
+    with
+      | Xml_parser.Error (Xml_parser.Empty, _) ->
+	pr_debug "End of input, exiting gracefully.";
+	exit 0
+      | Xml_parser.Error (err, loc) ->
+        pr_debug ("Syntax error in query: " ^ Xml_parser.error_msg err);
+	exit 1
+      | Serialize.Marshal_error ->
+        pr_debug "Incorrect query.";
+	exit 1
+      | any ->
+	pr_debug ("Fatal exception in coqtop:\n" ^ Printexc.to_string any);
+	exit 1
+  done;
+  pr_debug "Exiting gracefully.";
+  exit 0
+
+let rec parse = function
+  | "--help-XML-protocol" :: rest ->
+        Xmlprotocol.document Xml_printer.to_string_fmt; exit 0
+  | x :: rest -> x :: parse rest
+  | [] -> []
+
+let () = Coqtop.toploop_init := (fun args ->
+        let args = parse args in
+        Flags.make_silent true;
+        init_stdout ();
+        args)
+
+let () = Coqtop.toploop_run := loop
diff --git a/ide/ideutils.ml b/ide/ideutils.ml
index d8ca34f982..32d2bb97b3 100644
--- a/ide/ideutils.ml
+++ b/ide/ideutils.ml
@@ -272,15 +272,15 @@ let textview_width (view : #GText.view_skel) =
   let char_width = GPango.to_pixels metrics#approx_char_width in
   pixel_width / char_width
 
-type logger = Interface.message_level -> string -> unit
+type logger = Pp.message_level -> string -> unit
 
 let default_logger level message =
   let level = match level with
-  | Interface.Debug _ -> `DEBUG
-  | Interface.Info -> `INFO
-  | Interface.Notice -> `NOTICE
-  | Interface.Warning -> `WARNING
-  | Interface.Error -> `ERROR
+  | Pp.Debug _ -> `DEBUG
+  | Pp.Info -> `INFO
+  | Pp.Notice -> `NOTICE
+  | Pp.Warning -> `WARNING
+  | Pp.Error -> `ERROR
   in
   Minilib.log ~level message
 
diff --git a/ide/ideutils.mli b/ide/ideutils.mli
index 5fd97e3a55..5877d1270a 100644
--- a/ide/ideutils.mli
+++ b/ide/ideutils.mli
@@ -69,9 +69,9 @@ val requote : string -> string
 val textview_width : #GText.view_skel -> int
 (** Returns an approximate value of the character width of a textview *)
 
-type logger = Interface.message_level -> string -> unit
+type logger = Pp.message_level -> string -> unit
 
-val default_logger : Interface.message_level -> string -> unit
+val default_logger : Pp.message_level -> string -> unit
 (** Default logger. It logs messages that the casual user should not see. *)
 
 (** {6 I/O operations} *)
diff --git a/ide/interface.mli b/ide/interface.mli
new file mode 100644
index 0000000000..4e5e4a9cd7
--- /dev/null
+++ b/ide/interface.mli
@@ -0,0 +1,233 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Declarative part of the interface of CoqIde calls to Coq *)
+
+(** * Generic structures *)
+
+type raw = bool
+type verbose = bool
+
+(** The type of coqtop goals *)
+type goal = {
+  goal_id : string;
+  (** Unique goal identifier *)
+  goal_hyp : string list;
+  (** List of hypotheses *)
+  goal_ccl : string;
+  (** Goal conclusion *)
+}
+
+type evar = {
+  evar_info : string;
+  (** A string describing an evar: type, number, environment *)
+}
+
+type status = {
+  status_path : string list;
+  (** Module path of the current proof *)
+  status_proofname : string option;
+  (** Current proof name. [None] if no focussed proof is in progress *)
+  status_allproofs : string list;
+  (** List of all pending proofs. Order is not significant *)
+  status_proofnum : int;
+  (** An id describing the state of the current proof. *)
+}
+
+type goals = {
+  fg_goals : goal list;
+  (** List of the focussed goals *)
+  bg_goals : (goal list * goal list) list;
+  (** Zipper representing the unfocussed background goals *)
+  shelved_goals : goal list;
+  (** List of the goals on the shelf. *)
+  given_up_goals : goal list;
+  (** List of the goals that have been given up *)
+}
+
+type hint = (string * string) list
+(** A list of tactics applicable and their appearance *)
+
+type option_name = string list
+
+type option_value = Goptions.option_value =
+  | BoolValue   of bool
+  | IntValue    of int option
+  | StringValue of string
+
+(** Summary of an option status *)
+type option_state = Goptions.option_state = {
+  opt_sync  : bool;
+  (** Whether an option is synchronous *)
+  opt_depr  : bool;
+  (** Wheter an option is deprecated *)
+  opt_name  : string;
+  (** A short string that is displayed when using [Test] *)
+  opt_value : option_value;
+  (** The current value of the option *)
+}
+
+type search_constraint = Search.search_constraint =
+(** Whether the name satisfies a regexp (uses Ocaml Str syntax) *)
+| Name_Pattern of string
+(** Whether the object type satisfies a pattern *)
+| Type_Pattern of string
+(** Whether some subtype of object type satisfies a pattern *)
+| SubType_Pattern of string
+(** Whether the object pertains to a module *)
+| In_Module of string list
+(** Bypass the Search blacklist *)
+| Include_Blacklist
+
+(** A list of search constraints; the boolean flag is set to [false] whenever
+    the flag should be negated. *)
+type search_flags = (search_constraint * bool) list
+
+(** A named object in Coq. [coq_object_qualid] is the shortest path defined for
+    the user. [coq_object_prefix] is the missing part to recover the fully
+    qualified name, i.e [fully_qualified = coq_object_prefix + coq_object_qualid].
+    [coq_object_object] is the actual content of the object. *)
+type 'a coq_object = 'a Search.coq_object = {
+  coq_object_prefix : string list;
+  coq_object_qualid : string list;
+  coq_object_object : 'a;
+}
+
+type coq_info = {
+  coqtop_version : string;
+  protocol_version : string;
+  release_date : string;
+  compile_date : string;
+}
+
+(** Calls result *)
+
+type location = (int * int) option (* start and end of the error *)
+type state_id = Feedback.state_id
+type edit_id = Feedback.edit_id
+
+(* The fail case carries the current state_id of the prover, the GUI
+   should probably retract to that point *)
+type 'a value =
+  | Good of 'a
+  | Fail of (state_id * location * string)
+
+type ('a, 'b) union = ('a, 'b) Util.union
+
+(* Request/Reply message protocol between Coq and CoqIde *)
+
+(**  [add ((s,eid),(sid,v))] adds the phrase [s] with edit id [eid]
+     on top of the current edit position (that is asserted to be [sid])
+     verbosely if [v] is true.  The response [(id,(rc,s)] is the new state
+     [id] assigned to the phrase, some output [s].  [rc] is [Inl] if the new
+     state id is the tip of the edit point, or [Inr tip] if the new phrase
+     closes a focus and [tip] is the new edit tip *)
+type add_sty = (string * edit_id) * (state_id * verbose)
+type add_rty = state_id * ((unit, state_id) union * string)
+
+(** [edit_at id] declares the user wants to edit just after [id].
+    The response is [Inl] if the document has been rewound to that point,
+    [Inr (start,(stop,tip))] if [id] is in a zone that can be focused.
+    In that case the zone is delimited by [start] and [stop] while [tip]
+    is the new document [tip].  Edits made by subsequent [add] are always
+    performend on top of [id]. *)
+type edit_at_sty = state_id
+type edit_at_rty = (unit, state_id * (state_id * state_id)) union
+
+(** [query s id] executes [s] at state [id] and does not record any state
+    change but for the printings that are sent in response *)
+type query_sty = string * state_id
+type query_rty = string
+
+(** Fetching the list of current goals. Return [None] if no proof is in
+    progress, [Some gl] otherwise. *)
+type goals_sty = unit
+type goals_rty = goals option
+
+(** Retrieve the list of unintantiated evars in the current proof. [None] if no
+    proof is in progress. *)
+type evars_sty = unit
+type evars_rty = evar list option
+
+(** Retrieving the tactics applicable to the current goal. [None] if there is
+    no proof in progress. *)
+type hints_sty = unit
+type hints_rty = (hint list * hint) option
+
+(** The status, for instance "Ready in SomeSection, proving Foo", the
+    input boolean (if true) forces the evaluation of all unevaluated
+    statements *)
+type status_sty = bool
+type status_rty = status
+
+(** Search for objects satisfying the given search flags. *)
+type search_sty = search_flags
+type search_rty = string coq_object list
+
+(** Retrieve the list of options of the current toplevel *)
+type get_options_sty = unit
+type get_options_rty = (option_name * option_state) list
+
+(** Set the options to the given value. Warning: this is not atomic, so whenever
+    the call fails, the option state can be messed up... This is the caller duty
+    to check that everything is correct. *)
+type set_options_sty = (option_name * option_value) list
+type set_options_rty = unit
+
+(** Create a "match" template for a given inductive type.
+    For each branch of the match, we list the constructor name
+    followed by enough pattern variables. *)
+type mkcases_sty = string
+type mkcases_rty = string list list
+
+(** Quit gracefully the interpreter. *)
+type quit_sty = unit
+type quit_rty = unit
+
+(* Initialize, and return the initial state id.  The argument is the filename.
+ * If its directory is not in dirpath, it adds it.  It also loads
+ * compilation hints for the filename. *)
+type init_sty = string option
+type init_rty = state_id
+
+type about_sty = unit
+type about_rty = coq_info
+
+type handle_exn_sty = exn
+type handle_exn_rty = state_id * location * string
+
+(* Retrocompatibility stuff *)
+type interp_sty = (raw * verbose) * string
+(* spiwack: [Inl] for safe and [Inr] for unsafe. *)
+type interp_rty = state_id * (string,string) Util.union
+
+type stop_worker_sty = int
+type stop_worker_rty = unit
+
+
+type handler = {
+  add         : add_sty         -> add_rty;
+  edit_at     : edit_at_sty     -> edit_at_rty;
+  query       : query_sty       -> query_rty;
+  goals       : goals_sty       -> goals_rty;
+  evars       : evars_sty       -> evars_rty;
+  hints       : hints_sty       -> hints_rty;
+  status      : status_sty      -> status_rty;
+  search      : search_sty      -> search_rty;
+  get_options : get_options_sty -> get_options_rty;
+  set_options : set_options_sty -> set_options_rty;
+  mkcases     : mkcases_sty     -> mkcases_rty;
+  about       : about_sty       -> about_rty;
+  stop_worker : stop_worker_sty -> stop_worker_rty;
+  handle_exn  : handle_exn_sty  -> handle_exn_rty;
+  init        : init_sty        -> init_rty;
+  quit        : quit_sty        -> quit_rty;
+  (* Retrocompatibility stuff *)
+  interp      : interp_sty      -> interp_rty;
+}
+
diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml
index f58cdc6477..cd3e311358 100644
--- a/ide/wg_MessageView.ml
+++ b/ide/wg_MessageView.ml
@@ -12,7 +12,7 @@ class type message_view =
     method clear : unit
     method add : string -> unit
     method set : string -> unit
-    method push : Interface.message_level -> string -> unit
+    method push : Pp.message_level -> string -> unit
       (** same as [add], but with an explicit level instead of [Notice] *)
     method buffer : GText.buffer
       (** for more advanced text edition *)
@@ -43,8 +43,8 @@ let message_view () : message_view =
 
     method push level msg =
       let tags = match level with
-      | Interface.Error -> [Tags.Message.error]
-      | Interface.Warning -> [Tags.Message.warning]
+      | Pp.Error -> [Tags.Message.error]
+      | Pp.Warning -> [Tags.Message.warning]
       | _ -> []
       in
       if msg <> "" then begin
@@ -52,7 +52,7 @@ let message_view () : message_view =
         buffer#insert ~tags "\n"
       end
 
-    method add msg = self#push Interface.Notice msg
+    method add msg = self#push Pp.Notice msg
 
     method set msg = self#clear; self#add msg
 
diff --git a/ide/wg_MessageView.mli b/ide/wg_MessageView.mli
index cb84ae7337..8a0a2bd851 100644
--- a/ide/wg_MessageView.mli
+++ b/ide/wg_MessageView.mli
@@ -12,7 +12,7 @@ class type message_view =
     method clear : unit
     method add : string -> unit
     method set : string -> unit
-    method push : Interface.message_level -> string -> unit
+    method push : Pp.message_level -> string -> unit
       (** same as [add], but with an explicit level instead of [Notice] *)
     method buffer : GText.buffer
       (** for more advanced text edition *)
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
new file mode 100644
index 0000000000..09626172de
--- /dev/null
+++ b/ide/xmlprotocol.ml
@@ -0,0 +1,701 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** Protocol version of this file. This is the date of the last modification. *)
+
+(** WARNING: TO BE UPDATED WHEN MODIFIED! *)
+
+let protocol_version = "20140312"
+
+(** * Interface of calls to Coq by CoqIde *)
+
+open Util
+open Interface
+open Serialize
+open Xml_datatype
+
+(* Marshalling of basic types and type constructors *)
+module Xml_marshalling = struct
+
+let of_search_cst = function
+  | Name_Pattern s ->
+    constructor "search_cst" "name_pattern" [of_string s]
+  | Type_Pattern s ->
+    constructor "search_cst" "type_pattern" [of_string s]
+  | SubType_Pattern s ->
+    constructor "search_cst" "subtype_pattern" [of_string s]
+  | In_Module m ->
+    constructor "search_cst" "in_module" [of_list of_string m]
+  | Include_Blacklist ->
+    constructor "search_cst" "include_blacklist" []
+let to_search_cst = do_match "search_cst" (fun s args -> match s with
+  | "name_pattern" -> Name_Pattern (to_string (singleton args))
+  | "type_pattern" -> Type_Pattern (to_string (singleton args))
+  | "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)
+
+let of_coq_object f ans =
+  let prefix = of_list of_string ans.coq_object_prefix in
+  let qualid = of_list of_string ans.coq_object_qualid in
+  let obj = f ans.coq_object_object in
+  Element ("coq_object", [], [prefix; qualid; obj])
+
+let to_coq_object f = function
+| Element ("coq_object", [], [prefix; qualid; obj]) ->
+  let prefix = to_list to_string prefix in
+  let qualid = to_list to_string qualid in
+  let obj = f obj in {
+    coq_object_prefix = prefix;
+    coq_object_qualid = qualid;
+    coq_object_object = obj;
+  }
+| _ -> raise Marshal_error
+
+let of_option_value = function
+  | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i]
+  | BoolValue b -> constructor "option_value" "boolvalue" [of_bool b]
+  | StringValue s -> constructor "option_value" "stringvalue" [of_string s]
+let to_option_value = do_match "option_value" (fun s args -> match s with
+  | "intvalue" -> IntValue (to_option to_int (singleton args))
+  | "boolvalue" -> BoolValue (to_bool (singleton args))
+  | "stringvalue" -> StringValue (to_string (singleton args))
+  | _ -> raise Marshal_error)
+
+let of_option_state s =
+  Element ("option_state", [], [
+    of_bool s.opt_sync;
+    of_bool s.opt_depr;
+    of_string s.opt_name;
+    of_option_value s.opt_value])
+let to_option_state = function
+  | Element ("option_state", [], [sync; depr; name; value]) -> {
+      opt_sync = to_bool sync;
+      opt_depr = to_bool depr;
+      opt_name = to_string name;
+      opt_value = to_option_value value }
+  | _ -> raise Marshal_error
+
+
+let of_value f = function
+| Good x -> Element ("value", ["val", "good"], [f x])
+| Fail (id,loc, msg) ->
+  let loc = match loc with
+  | None -> []
+  | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in
+  let id = Stateid.to_xml id in
+  Element ("value", ["val", "fail"] @ loc, [id;PCData msg])
+let to_value f = function
+| Element ("value", attrs, l) ->
+  let ans = massoc "val" attrs in
+  if ans = "good" then Good (f (singleton l))
+  else if ans = "fail" then
+    let loc =
+      try
+        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
+    in
+    let id = Stateid.of_xml (List.hd l) in
+    let msg = raw_string (List.tl l) in
+    Fail (id, loc, msg)
+  else raise Marshal_error
+| _ -> raise Marshal_error
+
+let of_status s =
+  let of_so = of_option of_string in
+  let of_sl = of_list of_string in
+  Element ("status", [], [
+      of_sl s.status_path;
+      of_so s.status_proofname;
+      of_sl s.status_allproofs;
+      of_int s.status_proofnum; ])
+let to_status = function
+  | Element ("status", [], [path; name; prfs; pnum]) -> {
+      status_path = to_list to_string path;
+      status_proofname = to_option to_string name;
+      status_allproofs = to_list to_string prfs;
+      status_proofnum = to_int pnum; }
+  | _ -> raise Marshal_error
+
+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
+
+let of_goal g =
+  let hyp = of_list of_string g.goal_hyp in
+  let ccl = of_string g.goal_ccl in
+  let id = of_string g.goal_id in
+  Element ("goal", [], [id; hyp; ccl])
+let to_goal = function
+  | Element ("goal", [], [id; hyp; ccl]) ->
+    let hyp = to_list to_string hyp in
+    let ccl = to_string ccl in
+    let id = to_string id in
+    { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; }
+  | _ -> raise Marshal_error
+
+let of_goals g =
+  let of_glist = of_list of_goal in
+  let fg = of_list of_goal g.fg_goals in
+  let bg = of_list (of_pair of_glist of_glist) g.bg_goals in
+  let shelf = of_list of_goal g.shelved_goals in
+  let given_up = of_list of_goal g.given_up_goals in
+  Element ("goals", [], [fg; bg; shelf; given_up])
+let to_goals = function
+  | Element ("goals", [], [fg; bg; shelf; given_up]) ->
+    let to_glist = to_list to_goal in
+    let fg = to_list to_goal fg in
+    let bg = to_list (to_pair to_glist to_glist) bg in
+    let shelf = to_list to_goal shelf in
+    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
+
+let of_coq_info info =
+  let version = of_string info.coqtop_version in
+  let protocol = of_string info.protocol_version in
+  let release = of_string info.release_date in
+  let compile = of_string info.compile_date in
+  Element ("coq_info", [], [version; protocol; release; compile])
+let to_coq_info = function
+  | Element ("coq_info", [], [version; protocol; release; compile]) -> {
+      coqtop_version = to_string version;
+      protocol_version = to_string protocol;
+      release_date = to_string release;
+      compile_date = to_string compile; }
+  | _ -> raise Marshal_error
+
+end
+include Xml_marshalling
+
+(* Reification of basic types and type constructors, and functions
+   from to xml *)
+module ReifType : sig
+
+  type 'a val_t
+
+  val unit_t         : unit val_t
+  val string_t       : string val_t
+  val int_t          : int val_t
+  val bool_t         : bool val_t
+  
+  val option_t       : 'a val_t -> 'a option val_t
+  val list_t         : 'a val_t -> 'a list val_t
+  val pair_t         : 'a val_t -> 'b val_t -> ('a * 'b) val_t
+  val union_t        : 'a val_t -> 'b val_t -> ('a ,'b) union val_t
+
+  val goals_t        : goals val_t
+  val evar_t         : evar val_t
+  val state_t        : status val_t
+  val option_state_t : option_state val_t
+  val option_value_t : option_value val_t
+  val coq_info_t     : coq_info val_t
+  val coq_object_t   : 'a val_t -> 'a coq_object val_t
+  val state_id_t     : state_id val_t
+  val search_cst_t   : search_constraint val_t
+
+  val of_value_type : 'a val_t -> 'a -> xml
+  val to_value_type : 'a val_t -> xml -> 'a
+
+  val print         : 'a val_t -> 'a -> string
+
+  type value_type
+  val erase         : 'a val_t -> value_type
+  val print_type    : value_type -> string
+
+  val document_type_encoding : (xml -> string) -> unit
+
+end = struct
+
+  type value_type =
+    | Unit | String | Int | Bool
+
+    | Option of value_type
+    | List of value_type
+    | Pair of value_type * value_type
+    | Union of value_type * value_type
+    
+    | Goals | Evar | State | Option_state | Option_value | Coq_info
+    | Coq_object of value_type
+    | State_id
+    | Search_cst
+
+  type 'a val_t = value_type
+  
+  let erase (x : 'a val_t) : value_type = x
+
+  let unit_t         = Unit
+  let string_t       = String
+  let int_t          = Int
+  let bool_t         = Bool
+
+  let option_t x     = Option x
+  let list_t x       = List x
+  let pair_t x y     = Pair (x, y)
+  let union_t x y    = Union (x, y)
+
+  let goals_t        = Goals
+  let evar_t         = Evar
+  let state_t        = State
+  let option_state_t = Option_state
+  let option_value_t = Option_value
+  let coq_info_t     = Coq_info
+  let coq_object_t x = Coq_object x
+  let state_id_t     = State_id
+  let search_cst_t   = Search_cst
+
+  let of_value_type (ty : 'a val_t) : 'a -> xml =
+    let rec convert ty : 'a -> xml = match ty with
+      | Unit          -> Obj.magic of_unit
+      | Bool          -> Obj.magic of_bool
+      | String        -> Obj.magic of_string
+      | Int           -> Obj.magic of_int
+      | State         -> Obj.magic of_status
+      | Option_state  -> Obj.magic of_option_state
+      | Option_value  -> Obj.magic of_option_value
+      | Coq_info      -> Obj.magic of_coq_info
+      | Goals         -> Obj.magic of_goals
+      | Evar          -> Obj.magic of_evar
+      | List t        -> Obj.magic (of_list (convert t))
+      | Option t      -> Obj.magic (of_option (convert t))
+      | Coq_object t  -> Obj.magic (of_coq_object (convert t))
+      | Pair (t1,t2)  -> Obj.magic (of_pair (convert t1) (convert t2))
+      | Union (t1,t2) -> Obj.magic (of_union (convert t1) (convert t2))
+      | State_id      -> Obj.magic Stateid.to_xml
+      | Search_cst    -> Obj.magic of_search_cst
+    in
+      convert ty
+  
+  let to_value_type (ty : 'a val_t) : xml -> 'a =
+    let rec convert ty : xml -> 'a = match ty with
+      | Unit          -> Obj.magic to_unit
+      | Bool          -> Obj.magic to_bool
+      | String        -> Obj.magic to_string
+      | Int           -> Obj.magic to_int
+      | State         -> Obj.magic to_status
+      | Option_state  -> Obj.magic to_option_state
+      | Option_value  -> Obj.magic to_option_value
+      | Coq_info      -> Obj.magic to_coq_info
+      | Goals         -> Obj.magic to_goals
+      | Evar          -> Obj.magic to_evar
+      | List t        -> Obj.magic (to_list (convert t))
+      | Option t      -> Obj.magic (to_option (convert t))
+      | Coq_object t  -> Obj.magic (to_coq_object (convert t))
+      | Pair (t1,t2)  -> Obj.magic (to_pair (convert t1) (convert t2))
+      | Union (t1,t2) -> Obj.magic (to_union (convert t1) (convert t2))
+      | State_id      -> Obj.magic Stateid.of_xml
+      | Search_cst    -> Obj.magic to_search_cst
+    in
+      convert ty
+
+  let pr_unit () = ""
+  let pr_string s = Printf.sprintf "%S" s
+  let pr_int i = string_of_int i
+  let pr_bool b = Printf.sprintf "%B" b
+  let pr_goal (g : goals) =
+    if g.fg_goals = [] then
+      if g.bg_goals = [] then "Proof completed."
+      else
+        let rec pr_focus _ = function
+          | [] -> assert false
+          | [lg, rg] -> Printf.sprintf "%i" (List.length lg + List.length rg)
+          | (lg, rg) :: l ->
+            Printf.sprintf "%i:%a"
+              (List.length lg + List.length rg) pr_focus l in
+        Printf.sprintf "Still focussed: [%a]." pr_focus g.bg_goals
+    else
+      let pr_menu s = s in
+      let pr_goal { goal_hyp = hyps; goal_ccl = goal } =
+        "[" ^ String.concat "; " (List.map pr_menu hyps) ^ " |- " ^
+            pr_menu goal ^ "]" in
+      String.concat " " (List.map pr_goal g.fg_goals)
+  let pr_evar (e : evar) = "[" ^ e.evar_info ^ "]"
+  let pr_status (s : status) =
+    let path =
+      let l = String.concat "." s.status_path in
+      "path=" ^ l ^ ";" in
+    let name = match s.status_proofname with
+      | None -> "no proof;"
+      | Some n -> "proof = " ^ n ^ ";" in
+    "Status: " ^ path ^ name
+  let pr_coq_info (i : coq_info) = "FIXME"
+  let pr_option_value = function
+    | IntValue None -> "none"
+    | IntValue (Some i) -> string_of_int i
+    | StringValue s -> s
+    | BoolValue b -> if b then "true" else "false"
+  let pr_option_state (s : option_state) =
+    Printf.sprintf "sync := %b; depr := %b; name := %s; value := %s\n"
+      s.opt_sync s.opt_depr s.opt_name (pr_option_value s.opt_value)
+  let pr_list pr l = "["^String.concat ";" (List.map pr l)^"]"
+  let pr_option pr = function None -> "None" | Some x -> "Some("^pr x^")"
+  let pr_coq_object (o : 'a coq_object) = "FIXME"
+  let pr_pair pr1 pr2 (a,b) = "("^pr1 a^","^pr2 b^")"
+  let pr_union pr1 pr2 = function Inl x -> "Inl "^pr1 x | Inr x -> "Inr "^pr2 x
+
+  let pr_search_cst = function
+    | Name_Pattern s -> "Name_Pattern " ^ s
+    | Type_Pattern s -> "Type_Pattern " ^ s
+    | SubType_Pattern s -> "SubType_Pattern " ^ s
+    | In_Module s -> "In_Module " ^ String.concat "." s
+    | Include_Blacklist -> "Include_Blacklist"
+
+  let rec print = function
+  | Unit          -> Obj.magic pr_unit
+  | Bool          -> Obj.magic pr_bool
+  | String        -> Obj.magic pr_string
+  | Int           -> Obj.magic pr_int
+  | State         -> Obj.magic pr_status
+  | Option_state  -> Obj.magic pr_option_state
+  | Option_value  -> Obj.magic pr_option_value
+  | Search_cst    -> Obj.magic pr_search_cst
+  | Coq_info      -> Obj.magic pr_coq_info
+  | Goals         -> Obj.magic pr_goal
+  | Evar          -> Obj.magic pr_evar
+  | List t        -> Obj.magic (pr_list (print t))
+  | Option t      -> Obj.magic (pr_option (print t))
+  | Coq_object t  -> Obj.magic pr_coq_object
+  | Pair (t1,t2)  -> Obj.magic (pr_pair (print t1) (print t2))
+  | Union (t1,t2) -> Obj.magic (pr_union (print t1) (print t2))
+  | State_id      -> Obj.magic pr_int
+
+  (* This is to break if a rename/refactoring makes the strings below outdated *)
+  type 'a exists = bool
+
+  let rec print_type = function
+  | Unit          -> "unit"
+  | Bool          -> "bool"
+  | String        -> "string"
+  | Int           -> "int"
+  | State         -> assert(true : status exists); "Interface.status"
+  | Option_state  -> assert(true : option_state exists); "Interface.option_state"
+  | Option_value  -> assert(true : option_value exists); "Interface.option_value"
+  | Search_cst    -> assert(true : search_constraint exists); "Interface.search_constraint"
+  | Coq_info      -> assert(true : coq_info exists); "Interface.coq_info"
+  | Goals         -> assert(true : goals exists); "Interface.goals"
+  | Evar          -> assert(true : evar exists); "Interface.evar"
+  | List t        -> Printf.sprintf "(%s list)" (print_type t)
+  | Option t      -> Printf.sprintf "(%s option)" (print_type t)
+  | Coq_object t  -> assert(true : 'a coq_object exists);
+                     Printf.sprintf "(%s Interface.coq_object)" (print_type t)
+  | Pair (t1,t2)  -> Printf.sprintf "(%s * %s)" (print_type t1) (print_type t2)
+  | Union (t1,t2) -> assert(true : ('a,'b) CSig.union exists);
+                     Printf.sprintf "((%s, %s) CSig.union)" (print_type t1) (print_type t2)
+  | State_id      -> assert(true : Stateid.t exists); "Stateid.t"
+
+  let document_type_encoding pr_xml =
+    Printf.printf "\n=== Data encoding by examples ===\n\n";
+    Printf.printf "%s:\n\n%s\n\n" (print_type Unit) (pr_xml (of_unit ()));
+    Printf.printf "%s:\n\n%s\n%s\n\n" (print_type Bool)
+      (pr_xml (of_bool true)) (pr_xml (of_bool false));
+    Printf.printf "%s:\n\n%s\n\n" (print_type String) (pr_xml (of_string "hello"));
+    Printf.printf "%s:\n\n%s\n\n" (print_type Int) (pr_xml (of_int 256));
+    Printf.printf "%s:\n\n%s\n\n" (print_type State_id) (pr_xml (Stateid.to_xml Stateid.initial));
+    Printf.printf "%s:\n\n%s\n\n" (print_type (List Int)) (pr_xml (of_list of_int [3;4;5]));
+    Printf.printf "%s:\n\n%s\n%s\n\n" (print_type (Option Int))
+      (pr_xml (of_option of_int (Some 3))) (pr_xml (of_option of_int None));
+    Printf.printf "%s:\n\n%s\n\n" (print_type (Pair (Bool,Int)))
+      (pr_xml (of_pair of_bool of_int (false,3)));
+    Printf.printf "%s:\n\n%s\n\n" (print_type (Union (Bool,Int)))
+      (pr_xml (of_union of_bool of_int (Inl false)));
+    print_endline ("All other types are records represented by a node named like the OCaml\n"^
+                   "type which contains a flattened n-tuple.  We provide one example.\n");
+    Printf.printf "%s:\n\n%s\n\n" (print_type Option_state)
+      (pr_xml (of_option_state { opt_sync = true; opt_depr = false;
+        opt_name = "name1"; opt_value = IntValue (Some 37) }));
+
+end
+open ReifType
+
+(** Types reification, checked with explicit casts *)
+let add_sty_t : add_sty val_t = 
+  pair_t (pair_t string_t int_t) (pair_t state_id_t bool_t)
+let edit_at_sty_t : edit_at_sty val_t = state_id_t
+let query_sty_t : query_sty val_t = pair_t string_t state_id_t
+let goals_sty_t : goals_sty val_t = unit_t
+let evars_sty_t : evars_sty val_t = unit_t
+let hints_sty_t : hints_sty val_t = unit_t
+let status_sty_t : status_sty val_t = bool_t
+let search_sty_t : search_sty val_t = list_t (pair_t search_cst_t bool_t)
+let get_options_sty_t : get_options_sty val_t = unit_t
+let set_options_sty_t : set_options_sty val_t =
+  list_t (pair_t (list_t string_t) option_value_t)
+let mkcases_sty_t : mkcases_sty val_t = string_t
+let quit_sty_t : quit_sty val_t = unit_t
+let about_sty_t : about_sty val_t = unit_t
+let init_sty_t : init_sty val_t = option_t string_t
+let interp_sty_t : interp_sty val_t = pair_t (pair_t bool_t bool_t) string_t
+let stop_worker_sty_t : stop_worker_sty val_t = int_t
+
+let add_rty_t : add_rty val_t =
+  pair_t state_id_t (pair_t (union_t unit_t state_id_t) string_t)
+let edit_at_rty_t : edit_at_rty val_t =
+  union_t unit_t (pair_t state_id_t (pair_t state_id_t state_id_t))
+let query_rty_t : query_rty val_t = string_t
+let goals_rty_t : goals_rty val_t = option_t goals_t
+let evars_rty_t : evars_rty val_t = option_t (list_t evar_t)
+let hints_rty_t : hints_rty val_t =
+  let hint = list_t (pair_t string_t string_t) in
+  option_t (pair_t (list_t hint) hint)
+let status_rty_t : status_rty val_t = state_t
+let search_rty_t : search_rty val_t = list_t (coq_object_t string_t)
+let get_options_rty_t : get_options_rty val_t =
+  list_t (pair_t (list_t string_t) option_state_t) 
+let set_options_rty_t : set_options_rty val_t = unit_t
+let mkcases_rty_t : mkcases_rty val_t = list_t (list_t string_t)
+let quit_rty_t : quit_rty val_t = unit_t
+let about_rty_t : about_rty val_t = coq_info_t
+let init_rty_t : init_rty val_t = state_id_t
+let interp_rty_t : interp_rty val_t = pair_t state_id_t (union_t string_t string_t)
+let stop_worker_rty_t : stop_worker_rty val_t = unit_t
+
+let ($) x = erase x
+let calls = [|  
+  "Add",        ($)add_sty_t,         ($)add_rty_t;
+  "Edit_at",    ($)edit_at_sty_t,     ($)edit_at_rty_t;
+  "Query",      ($)query_sty_t,       ($)query_rty_t;
+  "Goal",       ($)goals_sty_t,       ($)goals_rty_t;
+  "Evars",      ($)evars_sty_t,       ($)evars_rty_t;
+  "Hints",      ($)hints_sty_t,       ($)hints_rty_t;
+  "Status",     ($)status_sty_t,      ($)status_rty_t;
+  "Search",     ($)search_sty_t,      ($)search_rty_t;
+  "GetOptions", ($)get_options_sty_t, ($)get_options_rty_t;
+  "SetOptions", ($)set_options_sty_t, ($)set_options_rty_t;
+  "MkCases",    ($)mkcases_sty_t,     ($)mkcases_rty_t;
+  "Quit",       ($)quit_sty_t,        ($)quit_rty_t;
+  "About",      ($)about_sty_t,       ($)about_rty_t;
+  "Init",       ($)init_sty_t,        ($)init_rty_t;
+  "Interp",     ($)interp_sty_t,      ($)interp_rty_t;
+  "StopWorker", ($)stop_worker_sty_t, ($)stop_worker_rty_t;
+|]
+
+type 'a call =
+  | Add        of add_sty
+  | Edit_at    of edit_at_sty
+  | Query      of query_sty
+  | Goal       of goals_sty
+  | Evars      of evars_sty
+  | Hints      of hints_sty
+  | Status     of status_sty
+  | Search     of search_sty
+  | GetOptions of get_options_sty
+  | SetOptions of set_options_sty
+  | MkCases    of mkcases_sty
+  | Quit       of quit_sty
+  | About      of about_sty
+  | Init       of init_sty
+  | StopWorker of stop_worker_sty
+  (* retrocompatibility *)
+  | Interp     of interp_sty
+
+let id_of_call = function
+  | Add _        -> 0
+  | Edit_at _    -> 1
+  | Query _      -> 2
+  | Goal _       -> 3
+  | Evars _      -> 4
+  | Hints _      -> 5
+  | Status _     -> 6
+  | Search _     -> 7
+  | GetOptions _ -> 8
+  | SetOptions _ -> 9
+  | MkCases _    -> 10
+  | Quit _       -> 11
+  | About _      -> 12
+  | Init _       -> 13
+  | Interp _     -> 14
+  | StopWorker _ -> 15
+
+let str_of_call c = pi1 calls.(id_of_call c)
+
+type unknown
+
+(** We use phantom types and GADT to protect ourselves against wild casts *)
+let add x         : add_rty call         = Add x
+let edit_at x     : edit_at_rty call     = Edit_at x
+let query x       : query_rty call       = Query x
+let goals x       : goals_rty call       = Goal x
+let evars x       : evars_rty call       = Evars x
+let hints x       : hints_rty call       = Hints x
+let status x      : status_rty call      = Status x
+let get_options x : get_options_rty call = GetOptions x
+let set_options x : set_options_rty call = SetOptions x
+let mkcases x     : mkcases_rty call     = MkCases x
+let search x      : search_rty call      = Search x
+let quit x        : quit_rty call        = Quit x
+let init x        : init_rty call        = Init x
+let interp x      : interp_rty call      = Interp x
+let stop_worker x : stop_worker_rty call = StopWorker x
+
+let abstract_eval_call handler (c : 'a call) : 'a value =
+  let mkGood x : 'a value = Good (Obj.magic x) in
+  try
+    match c with
+    | Add x        -> mkGood (handler.add x)
+    | Edit_at x    -> mkGood (handler.edit_at x)
+    | Query x      -> mkGood (handler.query x)
+    | Goal x       -> mkGood (handler.goals x)
+    | Evars x      -> mkGood (handler.evars x)
+    | Hints x      -> mkGood (handler.hints x)
+    | Status x     -> mkGood (handler.status x)
+    | Search x     -> mkGood (handler.search x)
+    | GetOptions x -> mkGood (handler.get_options x)
+    | SetOptions x -> mkGood (handler.set_options x)
+    | MkCases x    -> mkGood (handler.mkcases x)
+    | Quit x       -> mkGood (handler.quit x)
+    | About x      -> mkGood (handler.about x)
+    | Init x       -> mkGood (handler.init x)
+    | Interp x     -> mkGood (handler.interp x)
+    | StopWorker x -> mkGood (handler.stop_worker x)
+  with any ->
+    Fail (handler.handle_exn any)
+
+(** brain dead code, edit if protocol messages are added/removed *)
+let of_answer (q : 'a call) (v : 'a value) : xml = match q with
+  | Add _        -> of_value (of_value_type add_rty_t        ) (Obj.magic v)
+  | Edit_at _    -> of_value (of_value_type edit_at_rty_t    ) (Obj.magic v)
+  | Query _      -> of_value (of_value_type query_rty_t      ) (Obj.magic v)
+  | Goal _       -> of_value (of_value_type goals_rty_t      ) (Obj.magic v)
+  | Evars _      -> of_value (of_value_type evars_rty_t      ) (Obj.magic v)
+  | Hints _      -> of_value (of_value_type hints_rty_t      ) (Obj.magic v)
+  | Status _     -> of_value (of_value_type status_rty_t     ) (Obj.magic v)
+  | Search _     -> of_value (of_value_type search_rty_t     ) (Obj.magic v)
+  | GetOptions _ -> of_value (of_value_type get_options_rty_t) (Obj.magic v)
+  | SetOptions _ -> of_value (of_value_type set_options_rty_t) (Obj.magic v)
+  | MkCases _    -> of_value (of_value_type mkcases_rty_t    ) (Obj.magic v)
+  | Quit _       -> of_value (of_value_type quit_rty_t       ) (Obj.magic v)
+  | About _      -> of_value (of_value_type about_rty_t      ) (Obj.magic v)
+  | Init _       -> of_value (of_value_type init_rty_t       ) (Obj.magic v)
+  | Interp _     -> of_value (of_value_type interp_rty_t     ) (Obj.magic v)
+  | StopWorker _ -> of_value (of_value_type stop_worker_rty_t) (Obj.magic v)
+
+let to_answer (q : 'a call) (x : xml) : 'a value = match q with
+  | Add _        -> Obj.magic (to_value (to_value_type add_rty_t        ) x)
+  | Edit_at _    -> Obj.magic (to_value (to_value_type edit_at_rty_t    ) x)
+  | Query _      -> Obj.magic (to_value (to_value_type query_rty_t      ) x)
+  | Goal _       -> Obj.magic (to_value (to_value_type goals_rty_t      ) x)
+  | Evars _      -> Obj.magic (to_value (to_value_type evars_rty_t      ) x)
+  | Hints _      -> Obj.magic (to_value (to_value_type hints_rty_t      ) x)
+  | Status _     -> Obj.magic (to_value (to_value_type status_rty_t     ) x)
+  | Search _     -> Obj.magic (to_value (to_value_type search_rty_t     ) x)
+  | GetOptions _ -> Obj.magic (to_value (to_value_type get_options_rty_t) x)
+  | SetOptions _ -> Obj.magic (to_value (to_value_type set_options_rty_t) x)
+  | MkCases _    -> Obj.magic (to_value (to_value_type mkcases_rty_t    ) x)
+  | Quit _       -> Obj.magic (to_value (to_value_type quit_rty_t       ) x)
+  | About _      -> Obj.magic (to_value (to_value_type about_rty_t      ) x)
+  | Init _       -> Obj.magic (to_value (to_value_type init_rty_t       ) x)
+  | Interp _     -> Obj.magic (to_value (to_value_type interp_rty_t     ) x)
+  | StopWorker _ -> Obj.magic (to_value (to_value_type stop_worker_rty_t) x)
+
+let of_call (q : 'a call) : xml =
+  let mkCall x = constructor "call" (str_of_call q) [x] in
+  match q with
+  | Add x        -> mkCall (of_value_type add_sty_t         x) 
+  | Edit_at x    -> mkCall (of_value_type edit_at_sty_t     x) 
+  | Query x      -> mkCall (of_value_type query_sty_t       x) 
+  | Goal x       -> mkCall (of_value_type goals_sty_t       x) 
+  | Evars x      -> mkCall (of_value_type evars_sty_t       x) 
+  | Hints x      -> mkCall (of_value_type hints_sty_t       x) 
+  | Status x     -> mkCall (of_value_type status_sty_t      x) 
+  | Search x     -> mkCall (of_value_type search_sty_t      x) 
+  | GetOptions x -> mkCall (of_value_type get_options_sty_t x) 
+  | SetOptions x -> mkCall (of_value_type set_options_sty_t x) 
+  | MkCases x    -> mkCall (of_value_type mkcases_sty_t     x) 
+  | Quit x       -> mkCall (of_value_type quit_sty_t        x) 
+  | About x      -> mkCall (of_value_type about_sty_t       x) 
+  | Init x       -> mkCall (of_value_type init_sty_t        x)
+  | Interp x     -> mkCall (of_value_type interp_sty_t      x)
+  | StopWorker x -> mkCall (of_value_type stop_worker_sty_t x)
+
+let to_call : xml -> unknown call =
+  do_match "call" (fun s a ->
+    let mkCallArg vt a = to_value_type vt (singleton a) in
+    match s with
+    | "Add"        -> Add        (mkCallArg add_sty_t         a)
+    | "Edit_at"    -> Edit_at    (mkCallArg edit_at_sty_t     a)
+    | "Query"      -> Query      (mkCallArg query_sty_t       a)
+    | "Goal"       -> Goal       (mkCallArg goals_sty_t       a)
+    | "Evars"      -> Evars      (mkCallArg evars_sty_t       a)
+    | "Hints"      -> Hints      (mkCallArg hints_sty_t       a)
+    | "Status"     -> Status     (mkCallArg status_sty_t      a)
+    | "Search"     -> Search     (mkCallArg search_sty_t      a)
+    | "GetOptions" -> GetOptions (mkCallArg get_options_sty_t a)
+    | "SetOptions" -> SetOptions (mkCallArg set_options_sty_t a)
+    | "MkCases"    -> MkCases    (mkCallArg mkcases_sty_t     a)
+    | "Quit"       -> Quit       (mkCallArg quit_sty_t        a)
+    | "About"      -> About      (mkCallArg about_sty_t       a)
+    | "Init"       -> Init       (mkCallArg init_sty_t        a)
+    | "Interp"     -> Interp     (mkCallArg interp_sty_t      a)
+    | "StopWorker" -> StopWorker (mkCallArg stop_worker_sty_t a)
+    | _ -> raise Marshal_error)
+
+(** Debug printing *)
+
+let pr_value_gen pr = function
+  | Good v -> "GOOD " ^ pr v
+  | Fail (id,None,str) -> "FAIL "^Stateid.to_string id^" ["^str^"]"
+  | Fail (id,Some(i,j),str) ->
+      "FAIL "^Stateid.to_string id^
+        " ("^string_of_int i^","^string_of_int j^")["^str^"]"
+let pr_value v = pr_value_gen (fun _ -> "FIXME") v
+let pr_full_value call value = match call with
+  | Add _        -> pr_value_gen (print add_rty_t        ) (Obj.magic value) 
+  | Edit_at _    -> pr_value_gen (print edit_at_rty_t    ) (Obj.magic value) 
+  | Query _      -> pr_value_gen (print query_rty_t      ) (Obj.magic value) 
+  | Goal _       -> pr_value_gen (print goals_rty_t      ) (Obj.magic value) 
+  | Evars _      -> pr_value_gen (print evars_rty_t      ) (Obj.magic value) 
+  | Hints _      -> pr_value_gen (print hints_rty_t      ) (Obj.magic value) 
+  | Status _     -> pr_value_gen (print status_rty_t     ) (Obj.magic value) 
+  | Search _     -> pr_value_gen (print search_rty_t     ) (Obj.magic value) 
+  | GetOptions _ -> pr_value_gen (print get_options_rty_t) (Obj.magic value) 
+  | SetOptions _ -> pr_value_gen (print set_options_rty_t) (Obj.magic value) 
+  | MkCases _    -> pr_value_gen (print mkcases_rty_t    ) (Obj.magic value) 
+  | Quit _       -> pr_value_gen (print quit_rty_t       ) (Obj.magic value) 
+  | About _      -> pr_value_gen (print about_rty_t      ) (Obj.magic value) 
+  | Init _       -> pr_value_gen (print init_rty_t       ) (Obj.magic value)
+  | Interp _     -> pr_value_gen (print interp_rty_t     ) (Obj.magic value)
+  | StopWorker _ -> pr_value_gen (print stop_worker_rty_t) (Obj.magic value)
+let pr_call call = match call with
+  | Add x        -> str_of_call call ^ " " ^ print add_sty_t         x
+  | Edit_at x    -> str_of_call call ^ " " ^ print edit_at_sty_t     x
+  | Query x      -> str_of_call call ^ " " ^ print query_sty_t       x
+  | Goal x       -> str_of_call call ^ " " ^ print goals_sty_t       x
+  | Evars x      -> str_of_call call ^ " " ^ print evars_sty_t       x
+  | Hints x      -> str_of_call call ^ " " ^ print hints_sty_t       x
+  | Status x     -> str_of_call call ^ " " ^ print status_sty_t      x
+  | Search x     -> str_of_call call ^ " " ^ print search_sty_t      x
+  | GetOptions x -> str_of_call call ^ " " ^ print get_options_sty_t x
+  | SetOptions x -> str_of_call call ^ " " ^ print set_options_sty_t x
+  | MkCases x    -> str_of_call call ^ " " ^ print mkcases_sty_t     x
+  | Quit x       -> str_of_call call ^ " " ^ print quit_sty_t        x
+  | About x      -> str_of_call call ^ " " ^ print about_sty_t       x
+  | Init x       -> str_of_call call ^ " " ^ print init_sty_t        x
+  | Interp x     -> str_of_call call ^ " " ^ print interp_sty_t      x
+  | StopWorker x -> str_of_call call ^ " " ^ print stop_worker_sty_t x
+
+let document to_string_fmt =
+  Printf.printf "=== Available calls ===\n\n";
+  Array.iter (fun (cname, csty, crty) ->
+      Printf.printf "%12s :  %s\n %14s %s\n"
+        ("\""^cname^"\"") (print_type csty) "->" (print_type crty))
+    calls;
+  Printf.printf "\n=== Calls XML encoding ===\n\n";
+  Printf.printf "A call \"C\" carrying input a is encoded as:\n\n%s\n\n"
+    (to_string_fmt (constructor "call" "C" [PCData "a"]));
+  Printf.printf "A response carrying output b can either be:\n\n%s\n\n"
+    (to_string_fmt (of_value (fun _ -> PCData "b") (Good ())));
+  Printf.printf "or:\n\n%s\n\nwhere the attributes loc_s and loc_c are optional.\n"
+    (to_string_fmt (of_value (fun _ -> PCData "b")
+      (Fail (Stateid.initial,Some (15,34),"error message"))));
+  document_type_encoding to_string_fmt
+
+(* vim: set foldmethod=marker: *)
diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli
new file mode 100644
index 0000000000..42defce85b
--- /dev/null
+++ b/ide/xmlprotocol.mli
@@ -0,0 +1,56 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(** * Applicative part of the interface of CoqIde calls to Coq *)
+
+open Interface
+open Xml_datatype
+
+type 'a call
+
+type unknown
+
+val add         : add_sty         -> add_rty call
+val edit_at     : edit_at_sty     -> edit_at_rty call
+val query       : query_sty       -> query_rty call
+val goals       : goals_sty       -> goals_rty call
+val hints       : hints_sty       -> hints_rty call
+val status      : status_sty      -> status_rty call
+val mkcases     : mkcases_sty     -> mkcases_rty call
+val evars       : evars_sty       -> evars_rty call
+val search      : search_sty      -> search_rty call
+val get_options : get_options_sty -> get_options_rty call
+val set_options : set_options_sty -> set_options_rty call
+val quit        : quit_sty        -> quit_rty call
+val init        : init_sty        -> init_rty call
+val stop_worker : stop_worker_sty -> stop_worker_rty call
+(* retrocompatibility *)
+val interp      : interp_sty      -> interp_rty call
+
+val abstract_eval_call : handler -> 'a call -> 'a value
+
+(** * Protocol version *)
+
+val protocol_version : string
+
+(** * XML data marshalling *)
+
+val of_call : 'a call -> xml
+val to_call : xml -> unknown call
+
+val of_answer : 'a call -> 'a value -> xml
+val to_answer : 'a call -> xml -> 'a value
+
+(* Prints the documentation of this module *)
+val document : (xml -> string) -> unit
+
+(** * Debug printing *)
+
+val pr_call : 'a call -> string
+val pr_value : 'a value -> string
+val pr_full_value : 'a call -> 'a value -> string