[pp] Remove special tag type and handler from Pp.

For legacy reasons, pretty printing required to provide a "tag"
interpretation function `pp_tag`. However such function was not of much
use as the backends (richpp and terminal) hooked at the `Format.tag`
level.

We thus remove this unused indirection layer and annotate expressions
with their `Format` tags.

This is a step towards moving the last bit of terminal code out of the
core system.

3 files changed, 8 insertions, 29 deletions

diff --git a/ide/richpp.ml b/ide/richpp.ml
index 515090f71..ecf1f4021 100644
--- a/ide/richpp.ml
+++ b/ide/richpp.ml
@@ -24,10 +24,6 @@ type 'a context = {
   (** Pending opened nodes *)
   mutable offset : int;
   (** Quantity of characters printed so far *)
-  mutable annotations : 'a option Int.Map.t;
-  (** Map associating annotations to indexes *)
-  mutable index : int;
-  (** Current index of annotations *)
 }
 
 (** We use Format to introduce tags inside the pretty-printed document.
@@ -38,23 +34,13 @@ type 'a context = {
     marking functions. As those functions are called when actually writing to
     the device, the resulting tree is correct.
 *)
-let rich_pp width annotate ppcmds =
+let rich_pp width ppcmds =
 
   let context = {
     stack = Leaf;
     offset = 0;
-    annotations = Int.Map.empty;
-    index = (-1);
   } in
 
-  let pp_tag obj =
-    let index = context.index + 1 in
-    let () = context.index <- index in
-    let obj = annotate obj in
-    let () = context.annotations <- Int.Map.add index obj context.annotations in
-    string_of_int index
-  in
-
   let pp_buffer = Buffer.create 180 in
 
   let push_pcdata () =
@@ -81,12 +67,8 @@ let rich_pp width annotate ppcmds =
     | Leaf -> assert false
     | Node (node, child, pos, ctx) ->
       let () = assert (String.equal tag node) in
-      let annotation =
-        try Int.Map.find (int_of_string node) context.annotations
-        with _ -> None
-      in
       let annotation = {
-        annotation = annotation;
+        annotation = Some tag;
         startpos = pos;
         endpos = context.offset;
       } in
@@ -123,7 +105,7 @@ let rich_pp width annotate ppcmds =
   (** The whole output must be a valid document. To that
       end, we nest the document inside <pp> tags. *)
   pp_open_tag ft "pp";
-  Pp.(pp_with ~pp_tag ft ppcmds);
+  Pp.(pp_with ft ppcmds);
   pp_close_tag ft ();
 
   (** Get the resulting XML tree. *)
@@ -173,14 +155,13 @@ let xml_of_rich_pp tag_of_annotation attributes_of_annotation xml =
 type richpp = xml
 
 let richpp_of_pp width pp =
-  let annotate t = Some (Ppstyle.repr t)    in
   let rec drop = function
   | PCData s -> [PCData s]
   | Element (_, annotation, cs) ->
     let cs = List.concat (List.map drop cs) in
     match annotation.annotation with
     | None -> cs
-    | Some s -> [Element (String.concat "." s, [], cs)]
+    | Some s -> [Element (s, [], cs)]
   in
-  let xml = rich_pp width annotate pp in
+  let xml = rich_pp width pp in
   Element ("_", [], drop xml)
diff --git a/ide/richpp.mli b/ide/richpp.mli
index 0ceeeefc2..0fe4315b7 100644
--- a/ide/richpp.mli
+++ b/ide/richpp.mli
@@ -24,9 +24,7 @@ type 'annotation located = {
     that represents (located) annotations of this string.
     The [get_annotations] function is used to convert tags into the desired
     annotation. [width] sets the printing witdh of the formatter. *)
-val rich_pp : int ->
-  (Pp.pp_tag -> 'annotation option) -> Pp.std_ppcmds ->
-  'annotation located Xml_datatype.gxml
+val rich_pp : int -> Pp.std_ppcmds -> Pp.pp_tag located Xml_datatype.gxml
 
 (** [annotations_positions ssdoc] returns a list associating each
     annotations with its position in the string from which [ssdoc] is
diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml
index 6ed62082d..1d50aed03 100644
--- a/ide/xmlprotocol.ml
+++ b/ide/xmlprotocol.ml
@@ -112,7 +112,7 @@ let rec of_pp (pp : Pp.std_ppcmds) = let open Pp in match pp with
     | Ppcmd_string s      -> constructor "ppdoc" "string" [of_string s]
     | Ppcmd_glue sl       -> constructor "ppdoc" "glue"   [of_list of_pp sl]
     | Ppcmd_box (bt,s)    -> constructor "ppdoc" "box"    [of_pair of_box of_pp (bt,s)]
-    | Ppcmd_tag (t,s)     -> constructor "ppdoc" "tag"    [of_pair (of_list of_string) of_pp (t,s)]
+    | Ppcmd_tag (t,s)     -> constructor "ppdoc" "tag"    [of_pair of_string of_pp (t,s)]
     | Ppcmd_print_break (i,j)
                           -> constructor "ppdoc" "break"     [of_pair of_int of_int (i,j)]
     | Ppcmd_force_newline -> constructor "ppdoc" "newline"   []
@@ -126,7 +126,7 @@ let rec to_pp xpp = let open Pp in
     | "glue"      -> Ppcmd_glue (to_list to_pp (singleton args))
     | "box"       -> let (bt,s) = to_pair to_box to_pp (singleton args) in
                      Ppcmd_box(bt,s)
-    | "tag"       -> let (tg,s) = to_pair (to_list to_string) to_pp (singleton args) in
+    | "tag"       -> let (tg,s) = to_pair to_string to_pp (singleton args) in
                      Ppcmd_tag(tg,s)
     | "break"     -> let (i,j)   = to_pair to_int to_int (singleton args) in
                      Ppcmd_print_break(i, j)